Question

我有一个文件夹，我每天都会收到1000多个excel文件，它们都是相同的格式和结构。我想做的是每天在所有100多个文件上运行宏？

有自动化的方法吗？所以我可以每天在1000多个文件上继续运行相同的宏。

Answer 1

假设您将文件放入＆＃34;文件＆＃34;相对于主工作簿的目录，您的代码可能如下所示：

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（当前打开的工作簿）的上下文中。

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

Answer 2

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

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

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

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

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

这个常见宏文件的一个缺点是，如果启动多个Excel实例，您将收到一条错误消息，表明PERSONAL.XLSB文件已被Excel实例Nr使用。 1.只要你现在不添加新的宏，这就不成问题了。

Answer 3

非常感谢你

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

Answer 4

不是将值传递给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

Answer 5

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文件夹中

Answer 6

感谢Peterm !!

实际上，我使用你发布的完全相同的代码（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

End Sub

Sub DoWork（wb As Workbook）随着wb MyMacro 结束结束子

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

__________________编辑，宏现在正常_________________________

正如你所看到的，我不是VBA专家，但宏终于有效了。代码并不整齐，我不是SW程序员。

在某种程度上，它可能会帮助某些人。

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 如果Err.Number＆lt;＆gt; 0然后 '这里需要错误处理程序如果

结束

    Filename = Dir()

 Loop

End Sub

Sub DoWorkPlease（wb As Workbook）随着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

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

'然后我将整个事情复制到数字中，不再有公式，更容易以这种方式工作。

＆＃39; _____________________________________ ＆＃39;只获取价值 - 不再有公式

 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 \

下）

＆＃39; _____________________________________ ＆＃39;将作品保存在自己的文件夹下

Dim CleanName，CleanPath，CleanNewName As Variant CleanPath = ActiveWorkbook.Path CleanName = ActiveWorkbook.Name CleanName = Left（CleanName，34）'我拿出扩展名 CleanPath = CleanPath +＆＃34; \＆＃34; + CleanName CleanNewName = CleanPath +＆＃34; \＆＃34; + CleanName CleanNewName = CleanNewName +＆＃34; _clean.csv＆＃34; '并且我现在添加“clean”以获得不同的名称。

On Error Resume Next ActiveWorkbook.SaveAs Filename：= CleanNewName，FileFormat：= xlCSV，CreateBackup：= False

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

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

＆＃39;继续下一步

ActiveSheet.Move _ 后：= ActiveWorkbook.Sheets（1）

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

'以下是每个文件所需的各个范围。由于我有超过1000个文件，所以值得付出努力。

＆＃39; _______________分裂!! ______________________________

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

Dim CounterMode As Integer

如果TestingMode = 1则CounterMode = 1 Else 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）'在Cell（3,2）中我有个人名字的名字，所以我添加到文件名中。 TheName = ThePath +＆＃34; _＆＃34; + TheSwitch +＆＃34; .xls＆＃34;

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

Dim SheetName As Variant

'我将Sheets（1）命名为Sheet1，因为原始工作表具有测试的名称和日期。 '为了做一个情节我在所有文件上都有相同的名字，然后我重命名表 '原名

SheetName = ActiveSheet.Name ActiveWorkbook.Sheets（1）.Name =＆＃34; Sheet1＆＃34;

'这是情节

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

“保存 On Error Resume Next ActiveWorkbook.SaveAs Filename：= TheName，FileFormat：= 56，CreateBackup：= False

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

ActiveWorkbook.Close

接下来我＆＃39; ____________________那是分离___________________________ ＆＃39;打开屏幕更新： Application.ScreenUpdating = True Application.DisplayAlerts = True 范围（＆＃34; A1＆＃34）。选择

 End With

End Sub

在多个excel文件上运行相同的excel宏

6 个答案: