VBA need to cleanup code and simplify it if possible - excel

Question

I am still new to VBA, I am just curious if anyone has any recommendations for improving or simplifying this code. The program works fine the way it is, however it has to sort through anywhere from 10 to 30 files and marge them all. It can take a long time depending on the file size. The Excel files range from a few hundred lines to 800,000 each. Thanks for your help!
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

Answer 1

Not sure if my code does exactly what yours does (had no sample data/input to check the output against), but maybe something like this:
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