我还是VBA的新手，我只是好奇是否有人对改进或简化此代码有任何建议。该程序按原样运行良好，但是必须对10到30个文件进行任意排序，然后将它们全部整理。根据文件大小，可能要花费很长时间。 Excel文件的范围从几百行到800,000行。谢谢你的帮助！
Option Compare Text
Sub MergeAllFiles()
Dim wb As Workbook
Dim myPath As String, MyFile As String, myExtension As String, Col1 As
String, MyFolder As String, Title As String
Dim i As Integer, j As Integer, WS_Count As Integer, k As Integer
Dim FldrPicker As FileDialog
Dim Mynote As String, Answer As String
Mynote = "Does each file have the same number of export fields?"
Answer = MsgBox(Mynote, vbQuestion + vbYesNo, "Confirmation Needed")
If Answer = vbNo Then
MsgBox "Cancelled"
GoTo ResetSettings
End If
j = 1
i = 1
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select A Target Folder"
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.Clear
End With
Set NewBook = Workbooks.Add
With NewBook
.Title = "MasterList"
ActiveWorkbook.SaveAs Filename:="Mastersheet.xlsx"
End With
'Loop through each Excel file in folder
MyFile = Dir(MyFolder & "\", vbReadOnly)
If MyFile = "Batch.xlsx" Then GoTo NextLoop
Do While MyFile <> ""
DoEvents
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
Title = ActiveWorkbook.Name
ActiveWorkbook.Sheets(i).Select
With ActiveWorkbook.Sheets(i)
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode)
Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
End With
k = 1
l = 1
If j = 1 Then
k = 0
l = 0
End If
With Range("A1:AB1000000")
Set rFind = .Find(What:="Total Rate (Linehaul + Acc)",
LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
ActiveSheet.Range("A1:ABC1000000").AutoFilter
Field:=rFind.Column, Criteria1:="="
ActiveSheet.Range("A1:ABC1000000").Offset(1,
0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
ActiveSheet.AutoFilterMode = False
End With
ActiveSheet.UsedRange.Offset(l).Copy
Workbooks("Mastersheet.xlsx").Activate
Range("A" & Rows.Count).End(xlUp).Offset(k).Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders,
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(Title).Activate
Application.CutCopyMode = False
Workbooks(MyFile).Close SaveChanges:=True
j = j + 1
If j = 50 Then Exit Do
NextLoop:
MyFile = Dir
Loop
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
答案 0 :(得分：0)
不确定我的代码是否完全符合您的代码（没有示例数据/输入来检查输出是否与之相对），但是可能是这样的：
Option Explicit
Private Sub MergeAllFiles()
If MsgBox("Does each file have the same number of export fields?", vbQuestion + vbYesNo, "Confirmation Needed") = vbNo Then
MsgBox "Files do not have same number of export fields. Code will stop running now."
Exit Sub
End If
'Retrieve Target Folder Path From User
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select A Target Folder"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Folder selection cancelled. Code will stop running now."
Exit Sub
End If
Dim folderPath As String
folderPath = .SelectedItems(1)
If VBA.Strings.StrComp(VBA.Strings.Right$(folderPath, 1), "\", vbBinaryCompare) <> 0 Then
folderPath = folderPath & "\"
End If
End With
Dim masterWorksheet As Worksheet
With Workbooks.Add
.SaveAs Filename:=ThisWorkbook.Path & "\Mastersheet.xlsx"
Set masterWorksheet = .Worksheets(1)
End With
' If you're only interested in .xlsx files, then maybe specify the file extension upfront
' when using dir(). This ensures you only loop through files with the given file extension.
' But if you do want multiple file extensions, you could remove extension from the dir()
' and just check file extension inside the loop.
Dim Filename As String
Filename = VBA.FileSystem.Dir$(folderPath & "*.xlsx", vbReadOnly)
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim workbookToCopyFrom As Workbook
Dim fileCount As Long
Dim cellFound As Range
Dim blankRowsToDelete As Range
Dim lastRow As Long
Do While Len(Filename) <> 0
If VBA.Strings.StrComp(Filename, "Batch.xlsx", vbBinaryCompare) <> 0 Then
fileCount = fileCount + 1
Set workbookToCopyFrom = Application.Workbooks.Open(Filename:=folderPath & Filename, UpdateLinks:=False)
' Did you want to copy-paste from all worksheets
' or just the worksheet at the first index?
With workbookToCopyFrom.Worksheets(1)
If .AutoFilterMode Then .AutoFilter.ShowAllData
With .Range("A1:AB1000000")
' Presume this check is done because you want to include headers the first time,
' but exclude headers for any subsequent files.
If fileCount = 1 Then
.Rows(1).Copy masterWorksheet.Rows(1)
End If
Set cellFound = .Find(What:="Total Rate (Linehaul + Acc)", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
' It's worth checking if the previous line found anything
' If it didn't, you will get an error below when accessing the 'column' property
.AutoFilter Field:=cellFound.Column, Criteria1:="="
Set blankRowsToDelete = Application.Intersect(.EntireRow, .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow)
If Not (blankRowsToDelete Is Nothing) Then
blankRowsToDelete.Delete
End If
.Parent.AutoFilterMode = False
End With
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
.Range("A2:AB" & lastRow).Copy
masterWorksheet.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
workbookToCopyFrom.Close SaveChanges:=False
End If
End With
If fileCount = 50 Then Exit Do
End If
DoEvents
Filename = Dir$()
Loop
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub