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

【问题标题】：Optimizing Copy and Paste from one workbook to another in VBA在 VBA 中优化从一个工作簿复制和粘贴到另一个工作簿
【发布时间】：2020-02-18 21:42:38
【问题描述】：

我在一个文件夹中有几个 .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

...

【问题讨论】：

您的设置涉及多少行中的多少张？
感谢您的回复。根据文件，每个工作簿有 1 到 20 个工作表。每张纸上没有太多要复制的内容。每张纸最多可以复制 10 个单独的单元格。

标签： performance optimization copy-paste

【解决方案1】：

我刚刚意识到性能缓慢是由于在 excel 中编写但与从宏代码粘贴的范围相关联的公式。正如之前的堆栈溢出解决方案中解决的那样，我只是在代码的开头添加了“Application.Calculation = xlCalculationManual”，在代码的末尾添加了“Application.Calculation = xlCalculationAutomatic”，现在它要快得多。

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

【讨论】：