Оптимизация копирования и вставки из одной книги в другую в VBA

Question

У меня есть несколько шаблонов .xlsm в папке. Я пытаюсь прочитать все файлы Excel в этой папке и, основываясь на типе файла, он читает все листы в каждом файле и копирует указанные c ячейки в другую мою активную книгу (ThisWorkbook). Ниже приведен мой код, и он работает правильно. Однако это очень медленно. Я ищу любое решение, которое может ускорить код. Я уже пробовал Application.ScreenUpdating = False, но все еще очень медленно. Обработка 20 файлов занимает около 10 минут. У вас, ребята, есть предложения по увеличению скорости. Спасибо Veru Mich в Advance ...

    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 = xlCalculationAutomati c» в конце кода, и теперь это намного быстрее.

Я надеюсь, что это также полезно для тех, кто читает это