在多个excel文件上运行相同的excelmacros
我有一个文件夹，我在日常的基础上收到超过1000个excel文件，它们都是相同的格式和结构。 我想要做的是在每日所有100多个文件上运行一个macros？
有没有办法自动化呢？ 所以我可以每天在1000多个文件上继续运行这个macros。
假设你把你的文件放在相对于你的主工作簿的“Files”目录中，你的代码可能如下所示：
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()是你应用于所有文件的macros。 确保你在macros中的所有处理总是在wb （当前打开的工作簿）的上下文中。
免责声明：为简洁起见，所有可能的error handling都被忽略
问题的一部分可能是如何在1000个文件上运行这个？…我是否必须将此macros添加到所有1000个工作簿？
一种方法是将您的macros集中添加到文件PERSONAL.XLSB （有时扩展名可能不同）。 每次启动Excel时都会在后台加载此文件，并随时使您的macros可用。
最初PERSONAL.XLSB文件不会在那里。 要自动创build此文件，只需开始录制“虚拟”macros（使用电子表格左下方的录制button），然后select“个人macros工作簿”将其存储。
录制完macros后，可以使用Alt + F11打开VBA编辑器，您将看到PERSONAL.XLSB文件带有“虚拟”录制的macros。
我使用这个文件来存储总是可用的一般macros的加载，而不pipe打开哪个.xlsx文件。 我已经将这些macros添加到我自己的菜单function区中。
这个常见的macros文件的一个缺点是，如果启动多个Excel实例，则会收到一条错误消息，指出PERSONAL.XLSB文件已被Excel实例Nr使用。 1.这个没有问题，只要你现在不添加新的macros。
非常感谢你
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
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文件夹
而不是将值传递给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
感谢Peterm！
其实，我使用完全相同的代码发布（process_fiels和dowork）我的macros。
它工作辉煌！ （在我的问题之前）
我的1000个工作簿中的每一个都有84个工作表。 我自己的macros（最后工作！）将每个工作簿分成85个不同的文件（原始+每个工作表的简短版本保存为一个单独的文件）。
这使我有1000个文件+ 1000×85在同一个文件夹，这将是很难解决。
我真正需要的是使用Process_Files创build第一个文件，创build一个名为第一个文件的文件夹，将第一个文件移动到具有ist名称的文件夹，然后运行我的macros（在第一个文件新创build的文件夹…），回去取第二个文件，用第二个文件的名称创build一个文件夹，将第二个文件移动到名称为ist的文件夹，然后运行我的macros（在第二个在新创build的文件夹中的文件…）等…
最后，我应该将所有文件移动到与文件同名的文件夹中，原来的\ Files \文件夹的内容为1000个文件夹，其中包含原始文件的名称+ 84个文件我自己的macros已经做到了。
也许这是更容易的代码：
Sub ProcessFiles（）Dim Filename，Pathname As String Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\Files\" Filename = Dir(Pathname & "*.xls") Do While Filename <> ""
（这里应该读取文件名，用文件名创build一个文件夹，把文件移动到这个新创build的文件夹中）
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
非常感谢，这个网站是伟大的！
__________________编辑，macros现在工作_________________________
正如你所看到的，我不是VBA专家，但macros终于起作用了。 代码是不整齐的，我不是软件程序员。
在这里，有一天它可能会有所帮助。
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!!
在错误恢复下一个wb.Close SaveChanges：=假如果Err.Number <> 0那么'error handling程序需要在这里结束如果
Filename = Dir() Loop
结束小组
Sub DoWorkPlease（wb As Workbook）With wb
'因为我的应用程序有超过1800个单元格，每个列都耗费时间'我使用“testing模式”，我只能玩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
“加快macros观，closures更新和警报
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”，我添加“干净”，现在有一个不同的名字。
On Error Resume Next ActiveWorkbook.SaveAs文件名：= CleanNewName，FileFormat：= xlCSV，CreateBackup：= False
'如果有错误，我用文件名创build一个空文件夹，以知道哪个文件需要返工。
If Err.Number <> 0 Then MkDir (CleanPath + "_error_" + CleanName) End If
'继续下一步
ActiveSheet.Move _ After：= ActiveWorkbook.Sheets（1）
然后我把工作簿分成单独的文件和我需要的单个传感器的数据。
'这是我需要为每个文件的个人范围。 由于我有超过1000个文件，这是值得的。
'_______________分裂!! ______________________________
（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“ ，CH：CH，CN：CN，CT：CT“Col（5）=”A：A，F：F，CH：CH，CN：CN，CT：CT“ ：G：CH：CH，CN：CN，CT：CT“Col（7）=”A：A，H：H，CH：CH，CN：CN，CT：CT“ ，I：I，CH：CH，CN：CN，CT：CT“Col（9）=”A：A，J：J，CH：CH，CN：CN，CT： ：A，K：K，CH：CH，CN：CN，CT：CT“Col（12）=”A：A，L：L，CH：CH，CN：CN， “A：A，M：M，CH：CH，CN：CN，CT：CT”Col（13）=“A：A，N：N，CH：CH，CN：CN，CT：CT” ）=“A：A，O：O，CH：CH，CN：CN，CT：CT”Col（15）=“A：A，P：P，CI：CI，CO：CO，CT： （16）=“A：A，Q：Q，CI：CI，CO：CO，CT：CT” （18）=“A：A，S：S，CI：CI，CO：CO，CT：CT” ：CT“Col（20）=”A：A，U：U，CI：CI，CO：CO，CT：CT 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：C O，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） CJ，CP：CP，CT：CT“Col（31）=”A：A，AF：AF，CJ：CJ，CP：CP，CT：CT“Col（32） CJ：CJ，CP：CP，CT：CT“Col（33）=”A：A，AH：AH，CJ：CJ，CP：CP，CT：CT“Col（34） AI，CJ：CJ，CP：CP，CT：CT“Col（35）=”A：A，AJ：AJ，CJ：CJ，CP：CP，CT：CT“Col（36） AK：AK，CJ：CJ，CP：CP，CT：CT“Col（37）=”A：A，AL：AL，CJ：CJ，CP：CP，CT：CT“ A，AM：AM，CJ：CJ，CP：CP，CT：CT“Col（39）=”A：A，AN：AN，CJ：CJ，CP：CP，CT： A：A，AO：AO，CJ：CJ，CP：CP，CT：CT“Col（41）=”A：A，AP：AP，CJ：CJ，CP：CP，CT： A：A，A：AQ，CJ：CJ，CP：CP，CT：CT“Col（43）=”A：A，AR：AR，CK：CK，CQ：CQ，CT： 44）=“A：A，AS：AS，CK：CK，CQ：CQ，CT：CT”Col（45）=“A：A，AT：AT，CK：CK，CQ：CQ，CT： （46）=“A：A，AU：AU，CK：CK，CQ：CQ，CT：CT”Col（47）=“A：AV：AV，CK：CK，CQ：CQ，CT： CT“Col（48）=”A：A，AW：AW，CK：CK，CQ：CQ，CT：“A，AX：AX，CK：CK，CQ：CQ， CT：CT“Col（50）=”A：A，AY：AY，CK：CK，CQ：CQ，CT：“A：AZ：AZ，CK：CK，CQ： C CT：CT“Col（52）=”A：A，BA：BA，CK：CK，CQ：CQ，CT：CT“Col（53） CQ：CQ，CT：CT“Col（54）=”A：A，BC：BC，CK：CK，CQ：CQ，CT：CT“Col（55） CK，CQ：CQ，CT：CT“Col（56）=”A：A，BE：BE，CK：CK，CQ：CQ，CT：CT“Col（57） CL：CL，CR：CR，CT：CT“Col（58）=”A：A，BG：BG，CL：CL，CR：CR，CT： BH，CL：CL，CR：CR，CT：CT“Col（60）=”A：A，BI：BI，CL：CL，CR：CR，CT： BJ：BJ，CL：CL，CR：CR，CT：CT“Col（63）=”A：A，BK：BK，CL：CL，CR：CR，CT： A，BL：BL，CL：CL，CR：CR，CT：CT“Col（64）=”A：A，BM：BM，CL：CL，CR：CR，CT： A：A，BN：BN，CL：CL，CR：CR，CT：CT“Col（66）=”A：A，BO：BO，CL：CL，CR：CR，CT： =“A：A，BP：BP，CL：CL，CR：CR，CT：CT”Col（68）=“A：A，BQ：BQ，CL：CL，CR：CR，CT： （70）=“A：A，BR：BR，CL：CL，CR：CR，CT：CT” （71）=“A：A，BT：BT，CM：CM，CS：CS，CT：CT”Col（72）=“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：BY，BY：CM：CM，CS： C S，CT：CT“Col（77）=”A：A，BZ：BZ，CM：CM，CS：CS，CT：CT“Col（78）=”A：CA：CA，CM：CM， CS：CS，CT：CT“Col（79）=”A：A，CB：CB，CM：CM，CS：CS，CT：CT“ CM，CS：CS，CT：CT“Col（81）=”A：A，CD：CD，CM：CM，CS：CS，CT：CT“Col（82）=”A：CE，CE： CM：CM，CS：CS，CT：CT“Col（83）=”A：A，CF：CF，CM：CM，CS：CS，CT：CT“ CG，CM：CM，CS：CS，CT：CT“我想分割84个新文件，所以testing我只用1，而我用84
Dim CounterMode As Integer
如果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）'In单元格（3,2）我有个人名字的名字，所以我join了文件名。 TheName = ThePath +“_”+ TheSwitch +“.xls”
Range("A1").Select Sheets("Sheet1").Select Sheets("Sheet1").Copy Dim SheetName As Variant
'我把Sheet（1）命名为Sheet1，因为原始表格有testing的名字和date。 '我这样做是为了做一个情节，在所有的文件上都有相同的名字，然后我用'原来的名字重新命名表格
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文件名：= TheName，FileFormat：= 56，CreateBackup：= False
If Err.Number <> 0 Then MkDir (ThePath + "_error_" + TheName) End If ActiveWorkbook.Close
下一步我是____________________那是Split__________________________________'打开screenupdating：Application.ScreenUpdating = True Application.DisplayAlerts =真正的范围（“A1”）。
End With
结束小组