[英]How to apply same VBA code to multiple files in a folder?
我有一个操作需要应用到一个文件夹中最多 1000 个文件。
作为 output，将在需要处理的每个文件的单独文件夹中创建两个文件。 该代码适用于单个文件，但是，当代码应用于多个文件时，output 文件会显示为空的 Excel 表。
Sub wB_postup_test_all_files()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Dim Lastrow As Long
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "Some directory here"
MyFile = Dir(MyDir & "*.xlsx")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
'where core operation starts
Columns(1).EntireColumn.Delete
Columns(2).EntireColumn.Delete
Rows(1).Insert
Range("B1") = "=AVERAGE(B3:B4724)"
Range("A:A").Copy Range("D:D")
Range("B:B").Copy Range("E:E")
Range("D1") = "prumer"
Range("E2") = Range("B2").Value + "-prum"
Range("E1") = ""
Range("E3").Select
Do Until ActiveCell.Offset(0, -4).Value = ""
myCell0 = Range("B1").Value
myCell1 = ActiveCell.Offset(0, -3).Value
If IsEmpty(ActiveCell.Value) = True Then
ActiveCell.Value = "nic"
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Value = myCell1 - myCell0
ActiveCell.Offset(1, 0).Select
End If
Loop
Range("D:D").Copy Range("G:G")
Range("E:E").Copy
Range("H:H").PasteSpecial Paste:=xlPasteValues
Range("H2").Select
Do Until ActiveCell.Offset(1, -1).Value = ""
If ActiveCell.Value = "nic" Then
ActiveCell.Clear
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
ActiveCell.Clear
'plotting the scatter graph
Range("G3").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlUp)).Select
Range("G3:H4724").Select
Range("G4724").Activate
ActiveSheet.Shapes.AddChart2(240, xlXYScatterLinesNoMarkers).Select
ActiveChart.SetSourceData Source:=Range("G3:H4724")
Application.CutCopyMode = False
Application.CutCopyMode = False
ActiveChart.FullSeriesCollection(1).Name = Range("H2").Value
ActiveChart.Parent.Cut
Range("I4712").Select
Selection.End(xlUp).Select
Range("I4").Select
ActiveSheet.Paste
Range("I3").Select
'saving some columns as separate file
Dim Path As String
filename = Range("B2").Value
Path = "Some path here"
With Workbooks.Add
ThisWorkbook.Sheets(1).Range("G:G").Copy .Sheets(1).Range("A1")
ThisWorkbook.Sheets(1).Range("H:H").Copy .Sheets(1).Range("B1")
.SaveAs filename:=Path & filename & "-prum.xlsx"
.Close
End With
Sheets.Add.Name = "2"
Sheet1.Range("G:G").Copy Worksheets("2").Range("A1")
Sheet1.Range("H:H").Copy Worksheets("2").Range("B1")
Worksheets("2").Activate
Range("B1").Value = "=STDEVP(B3:B4724)"
Range("A:A").Copy Range("D:D")
Range("B:B").Copy Range("E:E")
Range("D1") = "prumer"
Range("E3").Select
Do Until ActiveCell.Offset(0, -4).Value = ""
myCell0 = Range("B1").Value
myCell1 = ActiveCell.Offset(0, -3).Value
If IsEmpty(ActiveCell.Value) = True Then
ActiveCell.Value = "nic"
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Value = myCell1 - myCell0
ActiveCell.Offset(1, 0).Select
End If
Loop
Range("D:D").Copy Range("G:G")
Range("E:E").Copy
Range("H:H").PasteSpecial Paste:=xlPasteValues
Range("H2").Select
Do Until ActiveCell.Offset(1, -1).Value = ""
If ActiveCell.Value = "nic" Then
ActiveCell.Clear
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
ActiveCell.Clear
Range("E1").Clear
Range("H1").Clear
'plotting the scatter graph
Range("G3").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlUp)).Select
Range("G3:H4724").Select
Range("G4724").Activate
ActiveSheet.Shapes.AddChart2(240, xlXYScatterLinesNoMarkers).Select
ActiveChart.SetSourceData Source:=Range("G3:H4724")
Application.CutCopyMode = False
Application.CutCopyMode = False
ActiveChart.FullSeriesCollection(1).Name = Range("H2").Value
ActiveChart.Parent.Cut
Range("I4712").Select
Selection.End(xlUp).Select
Range("I4").Select
ActiveSheet.Paste
Range("I3").Select
'saving some columns as separate file
With Workbooks.Add
ThisWorkbook.Sheets(1).Range("G:G").Copy .Sheets(1).Range("A1")
ThisWorkbook.Sheets(1).Range("H:H").Copy .Sheets(1).Range("B1")
.SaveAs filename:=Path & filename & "-prum ku SD.xlsx"
.Close
End With
'where core opreation ends
ActiveWorkbook.Save
ActiveWorkbook.Close True
MyFile = Dir()
Loop
End Sub
通过将各个部分放在一起来学习 vba 并不容易，因为它们是非常糟糕的例子。
基本思想是尽量减少与工作表的交互次数，因为这些会显着降低性能。 VBA 在 memory 工作和在 memory 工作意味着学习使用 ZA3EC7E793A809Z 是最好的。 此外，您将通过使用函数和子程序将代码分成更小的部分来简化问题的解决。
关于您的“空白”导出，可能是由于这部分：
With Workbooks.Add
ThisWorkbook.Sheets(1).Range("G:G").Copy .Sheets(1).Range("A1")
您正在从运行宏的工作表中导出数据，而不是您之前编辑的文件。
不过，如果您想学习，我重构了您的部分代码，以举例说明使用多个子/函数和 arrays 时的外观。 仅在完成所有转换后才写入工作表。
Option Explicit
Sub files()
'Fill in the path\folder where the files are
Dim MyPath As String, BaseWks As Worksheet
MyPath = ThisWorkbook.Path & "\test\"
'open files
Dim FilesInPath As String, mybook As Workbook
FilesInPath = Dir(MyPath & "*.xlsx")
Do While FilesInPath <> ""
Set mybook = Nothing
Set mybook = Workbooks.Open(MyPath & FilesInPath)
'build array & close WB
Dim arr
arr = Data(mybook)
'export array
Call Export(arr)
'reset vars
FilesInPath = Dir()
Loop
End Sub
'------------------------------------------------------------------------
' Supporting subs & functions of this module
'------------------------------------------------------------------------
Private Function Data(mybook As Workbook) As Variant 'use a function when you want the output to be returned to your main sub
'sheets in source workbooks
Dim SourceWs As Worksheet
Set SourceWs = mybook.Sheets(1)
'data from source workbooks
Dim arr
SourceWs.Rows(1).Insert shift:=xlShiftDown 'insert blank row
arr = SourceWs.Range("A1").CurrentRegion.Offset(0, 2).Value2 'get data but remove col A, B
'Modify array
Dim j As Long
arr(1, 2) = "=AVERAGE(B3:B4724)" 'B1 value
For j = 1 To UBound(arr)
arr(j, 4) = arr(j, 1) 'cold A to D
arr(j, 5) = arr(j, 2) 'cold B to E
Next j
arr(1, 4) = "prumer" 'd1
arr(1, 5) = "" 'e1
arr(2, 5) = arr(2, 2) & "-prum" 'e2
'dump to sheet
With SourceWs
.Range("A1").CurrentRegion.ClearContents 'clear old content
.Range(.Cells(1, 1), .Cells(UBound(arr), UBound(arr, 2))) = arr 'dumb modified arr to sheet
End With
mybook.Close savechanges:=True 'close the file
Data = arr 'return the modified array to the main sub, assuming it's this data that you want to export to a new workbook.
End Function
Private Sub Export(arr As Variant) 'use a sub when you just want to do something without returning output to the main sub
Dim Newwb As Workbook, sh As Worksheet, exportArr, Filename, j As Long
'arr
ReDim exportArr(1 To UBound(arr), 1 To 2) 'scale exportArr
Filename = "\" & CStr(arr(2, 2))
For j = 1 To UBound(arr)
exportArr(j, 1) = arr(j, 7) 'cold G to A
exportArr(j, 2) = arr(j, 8) 'cold H to B
Next j
Set Newwb = Workbooks.Add
With Newwb.ActiveSheet
.Range(.Cells(1, 1), .Cells(UBound(exportArr), UBound(exportArr, 2))).Value2 = exportArr
.SaveAs Filename:=ThisWorkbook.Path & Filename & "-prum2.xlsx" ', FileFormat:=xlsx, Local:=True 'save
End With
Newwb.Close savechanges:=False 'close the file
End Sub
如果您有任何问题，请不要犹豫。
VBA excel，如何 select 文件夹中的文件并将代码应用于所有文件？
[英]VBA excel, How to select files from a folder and apply code to all?
使用vba处理一个文件夹中的多个文件并将其放置在具有相同文件名的其他文件夹中
[英]processing multiple files in a folder and placing in a different folder with same file name using vba
VBA代码以始终相同的顺序查找文件夹中的文件组，并将特定的单元格粘贴到主文件中
[英]VBA code to find group of files in a folder, always in the same order, and paste specific cells into master file
声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.