VBA need to cleanup code and simplify it if possible

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