vba - 添加格式的更快方法

Question

我有 234,000 行数据和一个对其应用格式的宏。宏运行大约需要一分钟。如果可能的话，我会尽量缩短时间。

每次第 1 列发生变化时，都会添加一个边框，并且第二列之后的所有数据都会在每行之间添加一个边框并着色。

以下是数据示例：

这是宏：

Sub FormatData()
    Dim PrevScrnUpdate As Boolean
    Dim TotalRows As Long
    Dim TotalCols As Integer
    Dim PrevCell As Range
    Dim NextCell As Range
    Dim CurrCell As Range
    Dim i As Long
    Dim StartTime As Double

    StartTime = Timer

    PrevScrnUpdate = Application.ScreenUpdating
    Application.ScreenUpdating = False
    TotalRows = Rows(ActiveSheet.Rows.Count).End(xlUp).row
    TotalCols = Columns(ActiveSheet.Columns.Count).End(xlToLeft).Column

    Range(Cells(1, 1), Cells(1, TotalCols)).Font.Bold = True

    For i = 2 To TotalRows
        Set NextCell = Cells(i + 1, 1)
        Set CurrCell = Cells(i, 1)
        Set PrevCell = Cells(i - 1, 1)

        If CurrCell.Value <> NextCell.Value Then
            Range(CurrCell, Cells(i, 2)).Borders(xlEdgeBottom).LineStyle = xlSolid
        End If

        If CurrCell.Value <> PrevCell.Value Then
            Range(CurrCell, Cells(i, 2)).Borders(xlEdgeTop).LineStyle = xlSolid
        End If

        Range(Cells(i, 3), Cells(i, TotalCols)).BorderAround xlSolid
        Range(Cells(i, 3), Cells(i, TotalCols)).Interior.Color = RGB(200, 65, 65)
    Next

    Application.ScreenUpdating = PrevScrnUpdate
    Debug.Print Timer - StartTime
End Sub

编辑：这是一个结果示例：

编辑 2：我已经尝试过使用数组，但它并没有提高速度。

Answer 1

我可能会开始考虑将需要循环的列放在数组中并比较相邻的字符串。然后进行更新。循环和比较应该在数组上更快，边框格式的开销可能相同。

Dim ii As Long, firstRow As Integer ' a counter variable and the first row offset
Dim myColumn() As String ' create a string array   
ReDim myColumn(firstRow To firstRow + TotalRows) ' resize to hold the number of rows of data
myColumn = Range(Cells(1,1),Cells(1,TotalRows)).Value ' write the range to the array
For ii = (LBound(myColumn) + 1) To (UBound(myColumn) - 1)
   If myColumn(ii) <> myColumn(ii+1) Then
      Range(Cells(ii,1),Cells(ii,Ncol)).Borders(xlEdgeBottom).LineStyle = xlSolid
   Else If myColumn(ii) <> myColumn(ii-1)
      Range(Cells(ii,1),Cells(ii,Ncol)).Borders(xlEdgeTop).LineStyle = xlSolid
   End If 
Next

如果我知道需要迭代，我几乎总是尝试将大列表放入类型化数组中，除非它是微不足道的数据量。另一种选择可能是将整个范围复制到 type 数组中Range，更新与该值匹配的行，然后将它们放回原处。

Dim myColumns() As Range
ReDim myColumns(1 To TotalRows,1 To TotalCols)
myColumns = Range(Cells(1,1),Cells(TotalRows,TotalCols)
For ii = LBound(myColumns,1) + 1 To UBound(myColumns,1) - 1
    If myColumns(ii,1) <> myColumns(ii+1,1) Then
        ' ... update the bottom border
    Else If myColumns(ii,1) <> myColumns(ii-1,1) Then
        ' ... update the top border
    End If
Next
' Once we've done the updates, put the array back in place
Range(Cells(1,1),Cells(TotalRows,TotalCols)) = myColumns