VBA 需要清理代码并尽可能简化它

Question

我还是 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

Answer 1

不确定我的代码是否与您的代码完全相同（没有示例数据/输入来检查输出），但可能是这样的：

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