更快速地添加格式

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

如果我知道我需要迭代，我几乎总是尝试将大型列表放入类型化数组中，除非它是一个微不足道的数据量。另一个选项可能是将整个范围复制到类型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