서식을 더 빨리 추가하는 방법

Question

234,000 개의 데이터 행과 서식을 적용하는 매크로가 있습니다. 매크로는 실행하는 데 약 1 분이 걸립니다. 나는 가능한 한 시간을 줄이려고 노력하고있다.

열 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