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

Question

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

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

    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$9").Value
                   MyF = .Range("$B$9").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$4").Value
                   MyF = .Range("$R$4").Value
                   MyG = .Range("$R$5").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$8").Value
                   MyF = .Range("$B$8").Value
                   MyG = .Range("$D$8").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$4").Value
                   MyF = .Range("$E$4").Value
                   MyG = .Range("$E$5").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 = True

...

Answer 1

我刚刚意识到，性能下降的原因是用excel写的公式，但是这些公式链接到从宏代码粘贴的范围。正如在以前的堆栈溢出解决方案中所解决的那样，我只是在代码的开头添加了“ Application.Calculation = xlCalculationManual”，并在代码的末尾添加了“ Application.Calculation = xlCalculationAutomatic”，现在它的速度要快得多。 >

我希望对阅读此书的人也有用