VBA macro run-time too long

Question

Я написал несколько субтитров, которые затем вызывают из основного юнита. Отдельные подписчики работают очень быстро, большинство из них мгновенно (доза DoFind занимает несколько секунд для запуска из-за большого количества данных в таблице), однако, когда я запускаю основную часть, она занимает минуту до ее выполнения. Любые идеи/советы о том, почему это так?

Примечание. У меня не было большого опыта работы с VBA (все было изучено на прошлой неделе). Есть и другие макросы используются, но они не показаны, так как даже тест суб занимает примерно 1 минуту

Sub DoFind() 

    Dim i As Long 

    i = 1 

     Do While Sheets("Temp").Cells(i, "A").Value <> Empty 

       Dim BearingArray(6) As String 


       BearingArray(0) = Sheets("Temp").Cells(i, "A").Value 
       BearingArray(1) = Sheets("Temp").Cells(i, "B").Value 
       BearingArray(2) = Sheets("Temp").Cells(i, "C").Value 
       BearingArray(3) = Sheets("Temp").Cells(i, "D").Value 
       BearingArray(4) = Sheets("Temp").Cells(i, "E").Value 
       BearingArray(5) = Sheets("Temp").Cells(i, "F").Value 
       BearingArray(6) = Sheets("Temp").Cells(i, "G").Value 


       With Sheets("Calculations") 
        .Cells(17, "K").Value = BearingArray(0) 
        .Cells(19, "O").Value = BearingArray(1) 
        .Cells(20, "O").Value = BearingArray(2) 
        .Cells(23, "O").Value = BearingArray(3) 
        .Cells(22, "O").Value = BearingArray(4) 
        .Cells(26, "O").Value = BearingArray(5) 
        .Cells(17, "L").Value = BearingArray(6) 
       End With 

       i = i + 1 

        If Sheets("Calculations").Cells(17, "M").Value = "PASS" Then 
     Exit Do 
        Else 
        End If 
     Loop 
        If Sheets("Temp").Cells(i, "A").Value = Empty Then 
         MsgBox "No available bearing." 


        End If 


End Sub 

---

Sub Create_Sheet_Temp() 

    ThisWorkbook.Sheets.Add 
    ActiveSheet.Name = "Temp" 

' This creates a new worksheet called "Temp" 

End Sub 

---

Sub Copy_Paste() 

    Dim NewTable As ListObject 
    Sheets("Calculations").Activate 

    Set NewTable = Sheets("Calculations").ListObjects("Full_Bearings_List") 

    NewTable.Range.SpecialCells(xlCellTypeVisible).Select 
    NewTable.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy 
    Sheets("Temp").Range("A1").PasteSpecial xlPasteAll 
    Application.CutCopyMode = False 

     'This sub copies all visible cells from a filtered table and pastes them to the new sheet called "Temp" 

End Sub 

---

Sub test() 
    Create_Sheet_Temp 
    Copy_Paste 
    DoFind 

End Sub 

Answer 1

Вы можете ускорить ваш кода, сохраняя рабочие листы в переменных (впереди цикла).

Dim TempWS as Worksheet 
Dim CalcWS as Worksheet 
set tempws= Sheets("Temp") 
set CalcWS=Sheets("Calculations") 

Также объявите массив вне цикла. Также Id рекомендует использовать числовой индекс столбца.

Sheets("Temp").Cells(i, "G").Value 

к TempWS.Cells (я, 7) .Value

Сравнение с Empty не всегда лучший выбор, попробуйте

... <> "" 

EDIT: Для копирования попытаться использования т параметр назначения метода Копировать. Пример из справочной системы:

Worksheets("Sheet1").Range("A1:D4").Copy _ 
    destination:=Worksheets("Sheet2").Range("E5")