vba - Run same excel macro on multiple excel files

Question

I have a folder where I receive 1000+ excel files on daily bases they all are same format and structure. What I want to do is run a macro on all 100+ files on daily bases ?

Is there way to automate this ? So I can keep running that same macro on 1000+ files daily.

score 17 · Accepted Answer

假设您将文件放在相对于主工作簿的“文件”目录中，您的代码可能如下所示：

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "\Files\"
    Filename = Dir(Pathname & "*.xls")
    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        DoWork wb
        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop
End Sub

Sub DoWork(wb As Workbook)
    With wb
        'Do your work here
        .Worksheets(1).Range("A1").Value = "Hello World!"
    End With
End Sub

在此示例DoWork()中是您应用于所有文件的宏。确保您在宏中进行的所有处理始终在wb（当前打开的工作簿）的上下文中。

免责声明：为简洁起见，跳过了所有可能的错误处理。

score 3 · Accepted Answer

部分问题可能是如何在 1000 个文件上运行它？...我必须将此宏添加到所有 1000 个工作簿吗？

一种方法是将宏集中添加到文件中PERSONAL.XLSB（有时扩展名可能不同）。每次启动 Excel 时，此文件都会在后台加载，并使您的宏随时可用。

最初，PERSONAL.XLSB 文件将不存在。要自动创建此文件，只需开始录制“虚拟”宏（使用电子表格左下角的录制按钮）并选择“个人宏工作簿”将其存储。

录制宏后，您可以使用Alt+打开 VBA 编辑器，F11您将看到带有“虚拟”录制宏的 PERSONAL.XLSB 文件。

我使用此文件来存储始终可用的通用宏负载，与我打开的 .xlsx 文件无关。我已将这些宏添加到我自己的菜单功能区中。

此通用宏文件的一个缺点是，如果您启动多个 Excel 实例，您将收到一条错误消息，指出 PERSONAL.XLSB 文件已被 Excel 实例 Nr 使用。1. 这时候只要不添加新的宏就没有问题。

score 2 · Accepted Answer

非常感谢你

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "C:\Users\jkatanan\Desktop\20170206Glidepath\V37\"
    Filename = Dir(Pathname & "*.xls")
    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        BSAQmacro wb

        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop
End Sub
Sub DoWork(wb As Workbook)
    With wb
        'Do your work here
        .Worksheets(1).Range("A1").Value = "Hello World!"
    End With
End Sub

score 0 · Accepted Answer

除了将值传递给 DoWork 之外，还可以在Processfiles().

Sub ProcessFiles()

    Dim Filename, Pathname As String
    Dim wb1 As Workbook
    Dim wb2 As Workbook

    Dim Sheet As Worksheet
    Dim PasteStart As Range
    Dim Counter As Integer

    Set wb1 = ActiveWorkbook
    Set PasteStart = [RRimport!A1]

    Pathname = ActiveWorkbook.Path & "\For Macro to run\"
    Filename = Dir(Pathname & "*.xls")
    Do While Filename <> ""
        Set wb2 = Workbooks.Open(Pathname & Filename)
        For Each Sheet In wb2.Sheets
                With Sheet.UsedRange
                .Copy PasteStart
                Set PasteStart = PasteStart.Offset(.Rows.Count)
            End With
        Next Sheet
        wb2.Close
        Filename = Dir()
    Loop
End Sub

score 0 · Accepted Answer

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "\C:\Users\20098323\Desktop\EXCL\"
    Filename = Dir(Pathname & "*.xlsx")
    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        DoWork wb
        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop
End Sub

Sub DoWork(wb As Workbook)
    With wb
        'Do your work here
        .Worksheets(1).Range("A1").Value = "Hello World!"
    End With
End Sub

运行此代码时，它显示错误的文件名或编号。我已将所有文件存储在 ("\C:\Users\20098323\Desktop\EXCL\") EXCL 文件夹中

score 0 · Accepted Answer

这不是问题的确切答案，因为我只是试图在我打开的任何文件上运行单个脚本并且无法使其工作，但我认为这可能会帮助像我这样的其他人。一旦我将代码移动到 Visual Basic for Applications 对话框中的模块（转到“插入”然后“模块”），它就起作用了。一旦我将我的 VBA 代码添加到模块中，我就能够在 Excel 中打开任何其他文件（甚至是 CSV 文件）并转到宏，然后从另一个文件（包含带有代码的模块）中运行宏我打开的文件。

score -2 · Accepted Answer

谢谢彼得姆！！

实际上，我使用与您发布的代码完全相同的代码（process_fiels 和 dowork）完成了我的宏。

效果很好！！（在我的问题之前）

我的 1000 个工作簿中的每一个都有 84 个工作表。我自己的宏（终于起作用了！）将每个工作簿分成 85 个不同的文件（原始文件 + 每个工作表的简短版本，保存为单个文件）。

这让我在同一个文件夹中有 1000 个文件 + 1000x85，这真的很难理清。

我真正需要的是 Process_Files 获取第一个文件，使用第一个文件的名称创建一个文件夹，将第一个文件移动到具有 ist 名称的文件夹中，然后运行我的宏（在以第一个文件命名的文件夹中新创建的文件夹...），回去取第二个文件，用第二个文件的名字创建一个文件夹，将第二个文件移动到名字为ist的文件夹中，然后运行我的宏（在第二个命名的文件夹中）新创建的文件夹中的文件...）等...

最后，我应该将所有文件移动到与文件同名的文件夹中，原始 \Files\ 文件夹的内容将是 1000 个具有原始文件名称的文件夹，包含原始文件 + 84 个文件我自己的宏已经做到了。

也许使用代码更容易：

Sub ProcessFiles() Dim Filename, Pathname As String Dim wb As Workbook

Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""

（这里应该读取文件名，用文件名创建一个文件夹，将文件移动到这个新创建的文件夹中）

    Set wb = Workbooks.Open(Pathname & Filename)  <- open file, just as is.
    DoWork wb   <- do my macro,just as is
    wb.Close SaveChanges:=False      <- not save, to keep the original file

（回到原来的 \Files\ 文件夹）

    Filename = Dir()   <-   Next file, just as is
Loop

结束子

Sub DoWork(wb As Workbook) With wb MyMacro End With End Sub

非常感谢，这个网站很棒！

__________________编辑，宏现在可以工作了 _________________________

如您所见，我不是 VBA 专家，但宏终于可以工作了。代码一点也不整洁，我不是软件程序员。

就在这里，有一天它可能会对某人有所帮助。

Sub ProcessFiles_All() Dim Filename, Pathname, NewPath, FileSource, FileDestination As String Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "\Files\"
    Filename = Dir(Pathname & "*.csv")

 Do While Filename <> ""

     NewPath = Pathname & Left(Filename, 34) & "\"

 On Error Resume Next
     MkDir (NewPath)
 On Error GoTo 0

 Set wb = Workbooks.Open(Pathname & Filename)

    DoWorkPlease wb   '  <------------   It is important to say please!!

On Error Resume Next wb.Close SaveChanges:=False if Err.Number <> 0 then 'Error handler needed here End if

    Filename = Dir()

 Loop

结束子

Sub DoWorkPlease(wb As Workbook) With wb

' 因为我的应用程序每列有超过 1800 个单元格，而且非常耗时 ' 我使用“测试模式”，我只使用 18 个值。

 Dim TestingMode As Integer
 Dim ThisRange(1 To 4) As Variant

 TestingMode = 0

If TestingMode = 1 Then
   ThisRange(1) = "B2:CG18"
   ThisRange(2) = "CT2:CT18"
   ThisRange(3) = "CH2:CN18"
   ThisRange(4) = "CN2:CS18"
   Rows("19:18201").Select
   Selection.Delete Shift:=xlUp
End If

If TestingMode = 0 Then
   ThisRange(1) = "B2:CG18201"
   ThisRange(2) = "CT2:CT18201"
   ThisRange(3) = "CH2:CN18201"
   ThisRange(4) = "CN2:CS18201"
End If

' 加速宏，关闭更新和警报
Application.ScreenUpdating = False Application.DisplayAlerts = False

' 这是我的代码，它从数字操纵单元格值（传感器读取的值需要“转换”为真实世界的值。代码实际上不在此处。

'然后我将整个事情复制成数字，不再有公式，这样更容易工作。

'_____________________________________ '只获得价值 - 没有更多的公式

 Sheets.Add After:=Sheets(Sheets.Count)
 Sheets("Sheet1").Select
 Columns("A:CT").Select
 Selection.Copy
 Sheets("Sheet2").Select
 Columns("A:A").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
     :=False, Transpose:=False
 Application.CutCopyMode = False
 Selection.NumberFormat = "0"
 With Selection
     .HorizontalAlignment = xlCenter
     .VerticalAlignment = xlBottom
     .WrapText = False
     .Orientation = 0
     .AddIndent = False
     .IndentLevel = 0
     .ShrinkToFit = False
     .ReadingOrder = xlContext
     .MergeCells = False
 End With

' 然后我将这个新工作簿保存到具有自己名称的文件夹中（在文件夹 \FILES\

'____________________________________ '将作品保存在自己的文件夹下

Dim CleanName, CleanPath, CleanNewName As Variant CleanPath = ActiveWorkbook.Path CleanName = ActiveWorkbook.Name CleanName = Left(CleanName, 34) '我取出扩展名 CleanPath = CleanPath + "\" + CleanName CleanNewName = CleanPath + "\" + CleanName CleanNewName = CleanNewName + "_clean.csv" ' 我现在添加“clean”以具有不同的名称。

On Error Resume Next ActiveWorkbook.SaveAs Filename:=CleanNewName, FileFormat:=xlCSV, CreateBackup:=False

'如果出现错误，我会使用文件名创建一个空文件夹，以了解哪个文件需要返工。

If Err.Number <> 0 Then
    MkDir (CleanPath + "_error_" + CleanName)
End If

'继续下一步

ActiveSheet.Move_After:=ActiveWorkbook.Sheets(1)

' 然后，我将工作簿拆分为单独的文件，其中包含各个传感器所需的数据。

' 这是每个文件我需要的各个范围。由于我有超过 1000 个文件，因此值得付出努力。

'_______________ 分裂！！______________________________

暗色 Col(1 到 98) 作为变体 Col(1) = "A:A,B:B,CH:CH,CN:CN,CT:CT" Col(2) = "A:A,C:C,CH :CH,CN:CN,CT:CT" Col(3) = "A:A,D:D,CH:CH,CN:CN,CT:CT" Col(4) = "A:A,E:E ,CH:CH,CN:CN,CT:CT" Col(5) = "A:A,F:F,CH:CH,CN:CN,CT:CT" Col(6) = "A:A,G :G,CH:CH,CN:CN,CT:CT" Col(7) = "A:A,H:H,CH:CH,CN:CN,CT:CT" Col(8) = "A:A ,I:I,CH:CH,CN:CN,CT:CT" Col(9) = "A:A,J:J,CH:CH,CN:CN,CT:CT" Col(10) = "A :A,K:K,CH:CH,CN:CN,CT:CT" Col(11) = "A:A,L:L,CH:CH,CN:CN,CT:CT" Col(12) = "A:A,M:M,CH:CH,CN:CN,CT:CT" Col(13) = "A:A,N:N,CH:CH,CN:CN,CT:CT" Col(14 ) = "A:A,O:O,CH:CH,CN:CN,CT:CT" Col(15) = "A:A,P:P,CI:CI,CO:CO,CT:CT" Col (16) = "A:A,Q:Q,CI:CI,CO:CO,CT:CT"Col(17) = "A:A,R:R,CI:CI,CO:CO,CT:CT" Col(18) = "A:A,S:S,CI:CI,CO:CO,CT: CT" Col(19) = "A:A,T:T,CI:CI,CO:CO,CT:CT" Col(20) = "A:A,U:U,CI:CI,CO:CO, CT:CT" Col(21) = "A:A,V:V,CI:CI,CO:CO,CT:CT" Col(22) = "A:A,W:W,CI:CI,CO: CO,CT:CT" Col(23) = "A:A,X:X,CI:CI,CO:CO,CT:CT" Col(24) = "A:A,Y:Y,CI:CI, CO:CO,CT:CT" Col(25) = "A:A,Z:Z,CI:CI,CO:CO,CT:CT" Col(26) = "A:A,AA:AA,CI: CI,CO:CO,CT:CT" Col(27) = "A:A,AB:AB,CI:CI,CO:CO,CT:CT" Col(28) = "A:A,AC:AC, CI:CI,CO:CO,CT:CT" Col(29) = "A:A,AD:AD,CJ:CJ,CP:CP,CT:CT" Col(30) = "A:A,AE: AE,CJ:CJ,CP:CP,CT:CT" Col(31) = "A:A,AF:AF,CJ:CJ,CP:CP,CT:CT" Col(32) = "A:A, AG:AG,CJ:CJ,CP:CP,CT:CT"Col(33) = "A:A,AH:AH,CJ:CJ,CP:CP,CT:CT" Col(34) = "A:A,AI:AI,CJ:CJ,CP:CP,CT: CT" Col(35) = "A:A,AJ:AJ,CJ:CJ,CP:CP,CT:CT" Col(36) = "A:A,AK:AK,CJ:CJ,CP:CP, CT:CT" Col(37) = "A:A,AL:AL,CJ:CJ,CP:CP,CT:CT" Col(38) = "A:A,AM:AM,CJ:CJ,CP: CP,CT:CT" Col(39) = "A:A,AN:AN,CJ:CJ,CP:CP,CT:CT" Col(40) = "A:A,AO:AO,CJ:CJ, CP:CP,CT:CT" Col(41) = "A:A,AP:AP,CJ:CJ,CP:CP,CT:CT" Col(42) = "A:A,AQ:AQ,CJ: CJ,CP:CP,CT:CT" Col(43) = "A:A,AR:AR,CK:CK,CQ:CQ,CT:CT" Col(44) = "A:A,AS:AS, CK:CK,CQ:CQ,CT:CT" Col(45) = "A:A,AT:AT,CK:CK,CQ:CQ,CT:CT" Col(46) = "A:A,AU: AU,CK:CK,CQ:CQ,CT:CT" Col(47) = "A:A,AV:AV,CK:CK,CQ:CQ,CT:CT" Col(48) = "A:A, AW:AW,CK:CK,CQ:CQ,CT:CT" Col(49) = "A:A,AX:AX,CK:CK,CQ:CQ,CT:CT" Col(50) = "A:A,AY:AY,CK:CK,CQ:CQ, CT:CT" Col(51) = "A:A,AZ:AZ,CK:CK,CQ:CQ,CT:CT" Col(52) = "A:A,BA:BA,CK:CK,CQ: CQ,CT:CT" Col(53) = "A:A,BB:BB,CK:CK,CQ:CQ,CT:CT" Col(54) = "A:A,BC:BC,CK:CK, CQ:CQ,CT:CT" Col(55) = "A:A,BD:BD,CK:CK,CQ:CQ,CT:CT" Col(56) = "A:A,BE:BE,CK: CK,CQ:CQ,CT:CT" Col(57) = "A:A,BF:BF,CL:CL,CR:CR,CT:CT" Col(58) = "A:A,BG:BG, CL:CL,CR:CR,CT:CT" Col(59) = "A:A,BH:BH,CL:CL,CR:CR,CT:CT" Col(60) = "A:A,BI: BI,CL:CL,CR:CR,CT:CT" Col(61) = "A:A,BJ:BJ,CL:CL,CR:CR,CT:CT" Col(62) = "A:A, BK:BK,CL:CL,CR:CR,CT:CT" Col(63) = "A:A,BL:BL,CL:CL,CR:CR,CT:CT" Col(64) = "A: A,BM:BM,CL:CL,CR:CR,CT:CT" Col(65) = "A:A,BN:BN,CL:CL,CR:CR,CT:CT" Col(66) = "A:A,BO:BO,CL:CL, CR:CR,CT:CT" Col(67) = "A:A,BP:BP,CL:CL,CR:CR,CT:CT" Col(68) = "A:A,BQ:BQ,CL: CL,CR:CR,CT:CT" Col(69) = "A:A,BR:BR,CL:CL,CR:CR,CT:CT" Col(70) = "A:A,BS:BS, CL:CL,CR:CR,CT:CT" Col(71) = "A:A,BT:BT,CM:CM,CS:CS,CT:CT" Col(72) = "A:A,BU: BU,CM:CM,CS:CS,CT:CT" Col(73) = "A:A,BV:BV,CM:CM,CS:CS,CT:CT" Col(74) = "A:A, BW:BW,CM:CM,CS:CS,CT:CT" Col(75) = "A:A,BX:BX,CM:CM,CS:CS,CT:CT" Col(76) = "A: A,BY:BY,CM:CM,CS:CS,CT:CT" Col(77) = "A:A,BZ:BZ,CM:CM,CS:CS,CT:CT" Col(78) = " A:A,CA:CA,CM:CM,CS:CS,CT:CT" Col(79) = "A:A,CB:CB,CM:CM,CS:CS,CT:CT" Col(80) = "A:A,CC:CC,CM:CM,CS:CS,CT:CT" Col(81) = "A:A,CD:CD,CM:CM,CS:CS,CT:CT" Col(82) = "A:A,CE:CE, CM:CM,CS:CS,CT:CT" Col(83) = "A:A,CF:CF,CM:CM,CS:CS,CT:CT" Col(84) = "A:A,CG: CG,CM:CM,CS:CS,CT:CT" ' 我想拆分 84 个新文件，所以为了测试我只使用 1 个，而对于真实的我使用 84

将 CounterMode 调暗为整数

如果 TestingMode = 1 那么 CounterMode = 1 否则 CounterMode = 84

For i = 1 To CounterMode

' 此代码获取所需的列，并将其粘贴到新工作簿中。

 Sheets("Sheet1").Select
 Cells.Select
 Selection.ClearContents
 Range("A1").Activate
 Sheets(2).Select
 Range(Col(i)).Select
 Selection.Copy
 Sheets("Sheet1").Select
 ActiveSheet.Paste
 Application.CutCopyMode = False
 With Selection
     .HorizontalAlignment = xlCenter
     .VerticalAlignment = xlBottom
     .WrapText = False
     .Orientation = 0
     .AddIndent = False
     .IndentLevel = 0
     .ShrinkToFit = False
     .ReadingOrder = xlContext
     .MergeCells = False
 End With
 Columns("A:E").EntireColumn.AutoFit

' 保存单个文件

'_____________save the work________________

Dim ThePath, TheName, TheSwitch As String ThePath = ActiveWorkbook.Path + “\” TheName = Left(ActiveWorkbook.Name, 34) ' 从名称中取出扩展名 ThePath = ThePath + TheName TheSwitch = Cells(3, 2) ' 在单元格(3,2) 我有个人名字的名字，所以我加了文件名。TheName = ThePath + "_" + TheSwitch + ".xls"

Range("A1").Select
Sheets("Sheet1").Select
Sheets("Sheet1").Copy

Dim SheetName As Variant

' 我将 Sheets(1) 命名为 Sheet1，因为原始工作表具有测试的名称和日期。' 我这样做是为了在所有文件上使用相同的名称以进行绘图，然后我将工作表重命名为 ' 原始名称

SheetName = ActiveSheet.Name ActiveWorkbook.Sheets(1).Name = "Sheet1"

'这是情节

Columns("A:E").EntireColumn.AutoFit
Columns("B:E").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=Range("'Sheet1'!$B:$E")
ActiveChart.ChartType = xlXYScatterLinesNoMarkers

ActiveWorkbook.Sheets(1).Name = SheetName

'保存错误恢复下一个 ActiveWorkbook.SaveAs Filename:=TheName, FileFormat:=56, CreateBackup:=False

If Err.Number <> 0 Then
    MkDir (ThePath + "_error_" + TheName)
End If

ActiveWorkbook.Close

接下来我'____________________那是拆分__________________________________' 打开屏幕更新：Application.ScreenUpdating = True Application.DisplayAlerts = True Range("A1").Select

 End With

结束子

vba - Run same excel macro on multiple excel files

7 回答 7

Related

Reference