Ускоренный способ добавления форматирования

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