Как я могу ускорить этот код VBA, который включает в себя форматирование?

Question

Я устанавливаю новый ценовой график, который считывает выбранную информацию из вкладки «Регистрация» на основе выбранных критериев и копирует ее в новую вкладку. Эти данные отформатированы так, что это выглядит эстетично. Я считаю, что форматирование кода значительно замедляет скорость выполнения. Если возможно, я бы хотел ускорить это, поскольку я буду повторять это несколько раз.

Я ускорил программу на разумную сумму. Первоначально это заняло 30 секунд, тогда как сейчас это около 10 секунд. Я следил за информацией с этого сайта как можно лучше: https://www.soa.org/News-and-Publications/Newsletters/Compact/2012/january/com-2012-iss42-roper.aspx

Я чувствую, что еще есть возможности для улучшения, хотя я не уверен, как, и я пытаюсь выяснить, есть ли или есть лучшие способы улучшить код, чтобы он работал быстрее.

Option Explicit
Sub create_pricing_schedule()

'define workbook variables
Dim Start_Time As Double, End_Time As Double
Dim file1 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim namedRange1 As Range
Dim namedRange2 As Range
Set file1 = ThisWorkbook
Set ws2 = file1.Worksheets("Pricing Schedule")
Set ws3 = file1.Worksheets("Control")
Set ws4 = file1.Worksheets("Register")
Set namedRange1 = file1.Names("Client_Register").RefersToRange
Set namedRange2 = file1.Names("Pricing_Range").RefersToRange

'define general variables
Dim i As Integer
Dim collect(1 To 500, 1 To 10) As Variant
Dim rw As Range
Dim selectedClient As String
Dim lastrow As Integer, lastrow2 As Integer, lastrow3 As Integer

i = 1

'time how long it takes to improve efficiency
Start_Time = Timer

'speedup so less lagg
Call speedup

'delete everything from the pricing schedule/reset
With Sheets("Pricing Schedule")
    .UsedRange.ClearContents
    .Cells.Interior.ColorIndex = 0
    .Cells.Borders.LineStyle = xlNone
    .Cells.HorizontalAlignment = xlLeft
    .Cells.MergeCells = False
    .Range("A:Z").WrapText = False
    .Rows.RowHeight = "15"
End With

'resize the client register
lastrow = ws4.Range("A100000").End(xlUp).Row
With ActiveWorkbook.Names("Client_Register")
    .RefersTo = "=Register!$A$1:$AE$" & lastrow
End With

selectedClient = ws3.Range("B3").Value
'copy from database to the pricing schedule as a non formatted list of all the info - this runs quickly, but I am open to changing it
For Each rw In Range("Client_Register").Rows
    If Range("Client_Register").Cells(rw.Row, 2) = selectedClient Then
        collect(i, 1) = Range("Client_Register").Range("E" & rw.Row)
        collect(i, 2) = Range("Client_Register").Range("D" & rw.Row)
        collect(i, 3) = Range("Client_Register").Range("F" & rw.Row)
        collect(i, 4) = Range("Client_Register").Range("J" & rw.Row)
        collect(i, 5) = Range("Client_Register").Range("K" & rw.Row)
        collect(i, 6) = Range("Client_Register").Range("L" & rw.Row)
        collect(i, 7) = Range("Client_Register").Range("M" & rw.Row)
        collect(i, 8) = Range("Client_Register").Range("P" & rw.Row)
        collect(i, 9) = Range("Client_Register").Range("I" & rw.Row)
        collect(i, 10) = Range("Client_Register").Range("H" & rw.Row) ' used to determine if pass through fee

        ws2.Range("B" & i + 6) = collect(i, 1)
        ws2.Range("C" & i + 6) = collect(i, 2)
        ws2.Range("D" & i + 6) = collect(i, 3)
        ws2.Range("E" & i + 6) = collect(i, 4)
        ws2.Range("F" & i + 6) = collect(i, 5)
        ws2.Range("G" & i + 6) = collect(i, 6)
        ws2.Range("H" & i + 6) = collect(i, 7)
        ws2.Range("I" & i + 6) = collect(i, 8)
        ws2.Range("J" & i + 6) = collect(i, 9)
        ws2.Range("K" & i + 6) = collect(i, 10)

        i = i + 1
    End If
Next

'add in the colour and count how many rows there are
lastrow2 = ws2.Range("C5000").End(xlUp).Row
With ActiveWorkbook.Names("Pricing_Range")
    .RefersTo = "='Pricing Schedule'!$A$1:$K$" & lastrow2
End With

ws2.Range("B7" & ":" & "J" & lastrow2).Interior.Color = RGB(242, 242, 242)

'==========this bit is slow, can it be quicker?==========
'add spacing, titles, and colour to sub headers
i = 7
For Each rw In Range("Pricing_Range").Rows
    If Range("Pricing_Range").Cells(i, 3) <> Range("Pricing_Range").Cells(i + 1, 3) Then
        Range("Pricing_Range").Rows(i + 1).Insert Shift:=xlShiftDown
        Range("Pricing_Range").Rows(i + 1).Insert Shift:=xlShiftDown
        Range("Pricing_Range").Rows(i + 1).Interior.ColorIndex = 0
        Range("Pricing_Range").Rows(i + 2).Interior.ColorIndex = 0

        Range("Pricing_Range").Range("B" & i + 2 & ":" & "J" & i + 2).Interior.Color = RGB(255, 128, 1)
        Range("Pricing_Range").Range("B" & i + 2 & ":" & "J" & i + 2).Borders(xlEdgeTop).Color = RGB(0, 0, 0)
        Range("Pricing_Range").Range("B" & i + 2 & ":" & "J" & i + 2).Borders(xlEdgeBottom).Color = RGB(0, 0, 0)
        Range("Pricing_Range").Range("B" & i + 2).Value = Range("Pricing_Range").Range("C" & i + 3).Value

        'if it is a pass through fee then add it in to the sub headers
        If Range("Pricing_Range").Range("K" & i + 3).Value = "Pass-Through" Then
            Range("Pricing_Range").Range("J" & i + 2).Value = "Pass-Through Fees"
            Range("Pricing_Range").Range("J" & i + 2).HorizontalAlignment = xlRight
        End If
        i = i + 3

        Else
        i = i + 1
    End If
Next
'==================================================

'set up the main title rows
ws2.Select
Range("Pricing_Range").Range("B2").Value = ws3.Range("B3").Value
Range("Pricing_Range").Range("B2").Font.Size = 20
Range("Pricing_Range").Range("B2").Font.Bold = True
Range("Pricing_Range").Range("B2").Font.FontStyle = "Calibri Light"
Range("Pricing_Range").Range("B2:J3").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .MergeCells = True
    .Cells.Interior.Color = RGB(255, 128, 1)
    .Cells.Borders(xlEdgeTop).Color = RGB(0, 0, 0)
    .Cells.Borders(xlEdgeBottom).Color = RGB(0, 0, 0)
End With

'tidy up things in the sheet
With Worksheets("Pricing Schedule")
'set up the headers and first title
    .Range("B6") = .Range("C7")
    .Range("B5:J6").Interior.Color = RGB(255, 128, 1)
    .Range("B5:J5").Borders(xlEdgeTop).Color = RGB(0, 0, 0)
    .Range("B5:J5").Borders(xlEdgeBottom).Color = RGB(0, 0, 0)
    .Range("B6:J6").Borders(xlEdgeTop).Color = RGB(0, 0, 0)
    .Range("B6:J6").Borders(xlEdgeBottom).Color = RGB(0, 0, 0)
    .Range("B5").Value = "Fee Code"
    .Range("C5").Value = "Product Line"
    .Range("D5").Value = "Item"
    .Range("E5").Value = "Volume From"
    .Range("F5").Value = "Volume To"
    .Range("G5").Value = "Frequency"
    .Range("H5").Value = "Location"
    .Range("I5").Value = "Price"
    .Range("J5").Value = "Nature of Fee"

'tidy up column widths
    .Range("A5").RowHeight = 30
    .Range("A1").ColumnWidth = 2
    .Range("B1").ColumnWidth = 15
    .Range("C1").ColumnWidth = 40
    .Range("D1").ColumnWidth = 45
    .Range("E1").ColumnWidth = 11
    .Range("F1").ColumnWidth = 11
    .Range("G1").ColumnWidth = 35
    .Range("H1").ColumnWidth = 15
    .Range("I1").ColumnWidth = 12
    .Range("J1").ColumnWidth = 50
    .Range("J:J").WrapText = True
    .Range("K:K").Delete
End With

'clear the extra orange line at the end
lastrow3 = ws2.Range("B1000").End(xlUp).Row
With ws2.Rows(lastrow3 + 2)
    .Cells.Interior.ColorIndex = 0
    .Cells.Borders.LineStyle = xlNone
    .ClearContents
End With

'add print area
With Worksheets("Pricing Schedule")
    .PageSetup.Zoom = False
    .PageSetup.Orientation = xlPortrait
    .PageSetup.PrintArea = "$B$2:$J$" & lastrow3
    .PageSetup.FitToPagesWide = 1
    .PageSetup.FitToPagesTall = False
    .PageSetup.PrintTitleRows = "$2:$6"
End With

'return to normal
Call slowdown

'time how long it takes to improve efficiency
End_Time = Timer
Worksheets("Control").Cells(6, 2) = End_Time - Start_Time
End Sub

Sub speedup()
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False

End Sub

Sub slowdown()
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
End Sub

Answer 1

Пример использования С и назначения блока из массива:

'copy from database to the pricing schedule as a 
'   non formatted list of all the info - this runs quickly, 
'   but I am open to changing it
With Range("Client_Register")

    For Each rw In .Rows
        If .Cells(rw.Row, 2) = selectedClient Then

            collect(i, 1) = .Range("E" & rw.Row)
            collect(i, 2) = .Range("D" & rw.Row)
            collect(i, 3) = .Range("F" & rw.Row)
            collect(i, 4) = .Range("J" & rw.Row)
            collect(i, 5) = .Range("K" & rw.Row)
            collect(i, 6) = .Range("L" & rw.Row)
            collect(i, 7) = .Range("M" & rw.Row)
            collect(i, 8) = .Range("P" & rw.Row)
            collect(i, 9) = .Range("I" & rw.Row)
            collect(i, 10) = .Range("H" & rw.Row)

            'you could even skip the row-by-row population of values
            '  and assign as a block after exiting the loop
            ws2.Range("B" & i + 6).Resize(1, 10).Value = _
                    Array(collect(i, 1), collect(i, 2), collect(i, 3), _
                          collect(i, 4), collect(i, 5), collect(i, 6), _
                          collect(i, 7), collect(i, 8), collect(i, 9), _
                          collect(i, 10))

            i = i + 1
        End If
    Next

End With

Обратите внимание, что это прервется, если ваш Client_Register относится к диапазону, который не начинается на строке 1, из-за относительного диапазона.

Например:

 Range("A1:A10").Range("A1") 'refers to A1
 Range("A2:A10").Range("A1") 'refers to A2

Answer 2

Я нашел несколько строк, которые могли бы сэкономить вам время выполнения.

'****EDIT****Changed this to direct range reference rather than go through the Names collection.
'Set namedRange1 = file1.Names("Client_Register").RefersToRange
'Set namedRange2 = file1.Names("Pricing_Range").RefersToRange
Set namedRange1 = file1.Range("Client_Register")
Set namedRange2 = file1.Range("Pricing_Range")

Используемый диапазон занимает больше времени, вместо этого используйте .cell напрямую

'delete everything from the pricing schedule/reset
'****EDIT***
With ws2 'Sheets("Pricing Schedule")
    'used range takes more time rather use .cells directly
    .Cells.ClearContents

Вместо использования массивов вы можете напрямую обновлять значения, как показано ниже

'I am using i for the row count
        ws2.Range("B" & i + 6).Value = namedRange1.Cells(i, 5).Value
        ws2.Range("C" & i + 6).Value = namedRange1.Cells(i, 4).Value
        ws2.Range("D" & i + 6).Value = namedRange1.Cells(i, 6).Value
        ws2.Range("E" & i + 6).Value = namedRange1.Cells(i, 10).Value
        ws2.Range("F" & i + 6).Value = namedRange1.Cells(i, 11).Value
        ws2.Range("G" & i + 6).Value = namedRange1.Cells(i, 12).Value
        ws2.Range("H" & i + 6).Value = namedRange1.Cells(i, 12).Value
        ws2.Range("I" & i + 6).Value = namedRange1.Cells(i, 16).Value
        ws2.Range("J" & i + 6).Value = namedRange1.Cells(i, 9).Value
        ws2.Range("K" & i + 6).Value = namedRange1.Cells(i, 8).Value
        i = i + 1

Основной причиной вашей медленной работы является операция вставки . Попробуй проработать логику, чтобы не вставив. Если это невозможно, попробуйте вставить строки вне цикла в одну операцию, а не в цикл

        Range("Pricing_Range").Rows(i + 1).Insert Shift:=xlShiftDown
        Range("Pricing_Range").Rows(i + 1).Insert Shift:=xlShiftDown

Answer 3

Ваша обработка массива collect неэффективна. Подумайте о том, чтобы прочитать весь реестр клиентов в массив с помощью MyArray = Range.Value. Затем подготовьте выходной массив в памяти и запишите его на лист после того, как все циклы будут выполнены, за один раз, с TargetRange.Value = collect.

Избегайте вставки строк. Что не так с существующим? Если вы готовите все данные в массиве для вставки на лист, пустые элементы массива будут создавать пустые ячейки листа. Таким образом можно избежать вставки, и все, что вам нужно сделать, это отформатировать.

Существует время для каждого доступа к рабочему листу, будь то чтение или запись. Даже для форматирования попробуйте создать диапазоны, которые обрабатываются одинаково. Избегайте доступа к листу в виде петель.