По сути, я отказался от всей модели, в которой отдельные подпрограммы вызывали друг друга последовательно, и заменил ее одной подпрограммой, которая выполняет все функции.
Я решил переписать пример кода, удалив использование .Select (см. ссылка ) и определив переменные рабочего листа, когда это возможно.
Еще одна вещь, которую я заметил, была в Blank_Cells и Blank_Cells_Raw_Data, я не думаю, что вы хотели использовать здесь IsEmpty (который проверяет, инициализирована ли переменная; см. ссылка ), а скорее определяет, пуста ли сама ячейка. Я изменил это на If Application.WorksheetFunction.CountA(Range) = 0 в обоих случаях.
В Filter_Data я заметил, что вы устанавливаете значение одной ячейки (например, B2) на значение нескольких ячейки (например, A5:E5). При тестировании просто установите для первой ячейки первое значение в заданном диапазоне (например, ячейка A5). Предполагая, что вы не хотели делать что-то вроде Application.WorksheetFunction.Sum(ws2.Range("A5:E5")) (суммировать значения в этих ячейках), я просто изменил их, чтобы получить первую ячейку.
- Я изменил
Filter_Data и несколько других пятна, чтобы использовать ссылки на ячейки / столбцы вместо диапазонов, когда это возможно. - В
Copy_Up я заменил функцию .Copy фактической установкой значений ячеек (Копирование иногда может показаться странным, поэтому я стараюсь не использовать его, когда это возможно). - Кроме того, поскольку
.Delete и .Insert значительно замедляют выполнение макроса, я использовал метод, который избегает этого, просто проверяя одну группу из трех строк на «PurchaseOrderStatus» за раз, затем переходя к следующей и записывая в первую свободную в строке "Отфильтрованный отчет" вместо того, чтобы вставлять новые строки вверху. Это значительно ускорило макрос (от ~ 35 секунд до менее секунды).
Option Explicit
Sub Start_New_Report()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range
Dim newRow As Long, lastRow As Long, x As Long
Set ws1 = ThisWorkbook.Sheets("Filtered Report")
Set ws2 = ThisWorkbook.Sheets("PurchaseOrderStatus")
' Turn screen updating / calculation off for speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Clear Old data and prepare for new lines.
ws1.Range(ws1.Cells(2, 1), ws1.Cells(10000, 9)).ClearContents
ws1.Cells(2, 1) = 1
' Define last row
lastRow = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row - 2
' Iterate through all groups of 3 rows on PurchaseOrderStatus sheet
For x = 5 To lastRow Step 3
' Determine new row to write to
newRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
' Filter raw Syteline data to usable lines
ws1.Cells(newRow, 2) = ws2.Cells(x, 1)
ws1.Cells(newRow, 3) = ws2.Cells(x + 1, 1)
ws1.Cells(newRow, 4) = ws2.Cells(x + 2, 1)
ws1.Cells(newRow, 5) = ws2.Cells(x, 10)
ws1.Cells(newRow, 6) = ws2.Cells(x + 2, 15)
ws1.Cells(newRow, 7) = ws2.Cells(x + 1, 16)
ws1.Cells(newRow, 8) = ws2.Cells(x + 2, 16)
ws1.Cells(newRow, 9) = ws2.Cells(x + 2, 22)
' Copy Data Up from line below if cells are empty.
If Application.WorksheetFunction.CountA(ws1.Cells(newRow, 2)) = 0 Then
ws1.Cells(newRow, 2) = ws1.Cells(newRow - 1, 2)
ws1.Cells(newRow, 3) = ws1.Cells(newRow - 1, 3)
ws1.Cells(newRow, 4) = ws1.Cells(newRow - 1, 4)
End If
' Create next index number if not the last row
If x <> lastRow Then
ws1.Cells(newRow + 1, 1) = ws1.Cells(newRow, 1).Value + 1
End If
Next x
' Finish report and sort the order.
ws1.Range(ws1.Columns(1), ws1.Columns(9)).Sort _
Key1:=ws1.Cells(2, 1), _
Order1:=xlAscending, _
Header:=xlYes
' Turn screen updating / calculation back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub