在 VBA 中优化从一个工作簿到另一个工作簿的复制和粘贴

Question

我在一个文件夹中有几个 .xlsm 模板。我正在尝试通读该文件夹中的所有 excel 文件，并根据文件类型通读每个文件中的所有工作表，并将特定单元格复制到我的另一个活动工作簿 (ThisWorkbook) 中。以下是我的代码，它工作正常。但是它超级慢。我正在寻找可以加快代码速度的任何解决方案。我已经尝试过 Application.ScreenUpdating = False 但它仍然很慢。处理 20 个文件大约需要 10 分钟。你们对如何提高速度有什么建议吗？提前感谢 Veru mich ...

    Application.ScreenUpdating = False
    FileType = "*.xls*"     
    OutputRow = 5   
    Range("$B:$M0").ClearContents
    filepath = Range("$B") & "\" 

    ThisWorkbook.ActiveSheet.Range("B" & OutputRow).Activate
    OutputRow = OutputRow + 1
    Curr_File = Dir(filepath & FileType)
    Do Until Curr_File = ""
        Set FldrWkbk = Workbooks.Open(filepath & Curr_File, False, True)
        ThisWorkbook.ActiveSheet.Range("B" & OutputRow) = Curr_File
        OutputRow = OutputRow

        For Each sht In FldrWkbk.Sheets
            ThisWorkbook.ActiveSheet.Range("C" & OutputRow) = sht.Name
            If Workbooks(Curr_File).Worksheets(sht.Name).Range("B7") = "Project Number" Then
             For i = 1 To 4
              If IsEmpty(Workbooks(Curr_File).Worksheets(sht.Name).Cells(10, 5 + 2 * i)) = False Then
                With Workbooks(Curr_File).Worksheets(sht.Name)
                   MyE = .Cells(10, 5 + 2 * i).Value
                   MyF = .Cells(11, 5 + 2 * i).Value
                End With
                With ThisWorkbook.ActiveSheet
                  .Range("D" & OutputRow).Value = "Unit Weight"
                  .Range("E" & OutputRow).Value = MyE
                  .Range("F" & OutputRow).Value = MyF
                End With
                OutputRow = OutputRow + 1
              End If
             Next
            OutputRow = OutputRow - 1
            ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("C6") = "PROJECT NUMBER" Then
             With Workbooks(Curr_File).Worksheets(sht.Name)
                   MyE = .Range("$H").Value
                   MyF = .Range("$B").Value

             End With
             With ThisWorkbook.ActiveSheet
            .Range("D" & OutputRow).Value = "Specific Gravity"
            .Range("E" & OutputRow).Value = MyE
            .Range("F" & OutputRow).Value = MyF
            End With

            ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("C6") = "Project Number" Then

            With Workbooks(Curr_File).Worksheets(sht.Name)
                   MyE = .Range("$E").Value
                   MyF = .Range("$R").Value
                   MyG = .Range("$R").Value
             End With
             With ThisWorkbook.ActiveSheet
             .Range("D" & OutputRow).Value = "Sieve & Hydrometer"
             .Range("E" & OutputRow).Value = MyE
             .Range("F" & OutputRow).Value = MyF
             .Range("G" & OutputRow).Value = MyG
            End With

            ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("A6") = "PROJECT NUMBER" Then
            ThisWorkbook.ActiveSheet.Range("D" & OutputRow).Value = "Moisture Content"

            Last = Workbooks(Curr_File).Worksheets(sht.Name).Cells(Rows.Count, "J").End(xlUp).Row
            ThisWorkbook.ActiveSheet.Range("I" & OutputRow).Value = 
            Workbooks(Curr_File).Worksheets(sht.Name).Cells(Last, 10)

            ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("C5") = "Project Number" Then
            With Workbooks(Curr_File).Worksheets(sht.Name)
                   MyE = .Range("$H").Value
                   MyF = .Range("$B").Value
                   MyG = .Range("$D").Value
             End With
             With ThisWorkbook.ActiveSheet
             .Range("D" & OutputRow).Value = "Atterberg Limits"
             .Range("E" & OutputRow).Value = MyE
             .Range("F" & OutputRow).Value = MyF
             .Range("G" & OutputRow).Value = MyG
             End With

            ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("B5") = "Project Number" Then
            With Workbooks(Curr_File).Worksheets(sht.Name)
                   MyE = .Range("$G").Value
                   MyF = .Range("$E").Value
                   MyG = .Range("$E").Value
            End With
            With ThisWorkbook.ActiveSheet
             .Range("D" & OutputRow).Value = "Gradation Size"
             .Range("E" & OutputRow).Value = MyE
             .Range("F" & OutputRow).Value = MyF
             .Range("G" & OutputRow).Value = MyG
             End With
            End If
            OutputRow = OutputRow + 1
        Next sht
        FldrWkbk.Close SaveChanges:=False
        Curr_File = Dir
    Loop
    Set FldrWkbk = Nothing

Application.ScreenUpdating = 真

...

Answer 1

我刚刚意识到性能下降是由于 excel 中编写的公式，但链接到从宏代码粘贴的范围。由于在之前的堆栈溢出解决方案中已解决，我只是在代码的开头添加了 "Application.Calculation = xlCalculationManual" 并在代码的末尾添加了 "Application.Calculation = xlCalculationAutomatic"，现在速度快多了。

我希望它对阅读本文的人也有用

在 VBA 中优化从一个工作簿到另一个工作簿的复制和粘贴

Optimizing Copy and Paste from one workbook to another in VBA

optimization

performance

copy-paste