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

您对collect数组的处理效率低下。考虑使用MyArray = Range.Value将整个客户端寄存器读入数组。然后将输出数组准备在内存中，并在所有循环完成后使用TargetRange.Value = collect一次性将其写入工作表。

避免插入行。现有的怎么了？如果您准备将数组中的所有数据粘贴到工作表中，则空数组元素将产生空工作表单元格。这样可以避免所有插入操作，而您所需要做的就是格式化。

每次读取或写入工作表都需要花费时间。即使是格式化，也请尝试创建以相同方式处理的范围。避免循环访问工作表。

Answer 2

With和从数组分配块的示例：

'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引用了一个不在Row1上开始的范围，则会中断此操作。

例如：

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

Answer 3

我发现了几行可以节省您一些执行时间。

'****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")

使用范围会花费更多时间，而不是直接使用.cells

'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

如何加快涉及格式化的vba代码的速度？

3 个答案: