CODEWITHSUNDEEP
vbaexcel
Ripster
Ripster

Reputation: 3595

Faster way to add formatting

I have 234,000 rows of data and a macro that applies formatting to it. The macro takes about a minute to run. I'm trying to cut the time down if possible.

Each time there is a change in column 1 a border is added and all data after the second column has a boarder added between each row and gets colored.

Here is an example of the data:

Example Data

This is the macro:

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

Edit: Here is an example of the result:

Result

Edit 2: I have tried this with arrays and it does not improve the speed.

Upvotes: 0

Views: 1370

Answers (1)

Max
Max

Reputation: 156

I'd probably start thinking in terms of putting the column you need to loop over in an array and comparing adjacent strings. Then do the update. Loop and comparison should be faster over the array with probably the same overhead for the border formatting.

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

I almost always try to get big lists into a typed array if I know I need to iterate unless it's a trivial amount of data. The other option might be to copy the entire range into an array of type Range, update the rows that match on that value, then put them back again.

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

Upvotes: 1

Related Questions