Не уверен, что мой код делает именно то, что делает ваш (не имел образцов данных / входных данных для проверки выходных данных), но может быть что-то вроде этого:
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