excelvbams-office

vba: log cleaning macro: how to optimize for faster execution?


I'm running a macro that I made to delete the log contents and reformat the table in case that any format changes occurred while using it, the macro does what I intended but it takes about 30 minutes to finish running, all the while excel is completely frozen and unusable. Upon checking task manager on the process usage column, it seems excel is only using about 12.5% of my processing capacity, is there any way that I can make this multithread or that I can optimize the code to not take forever?

P.S. I decided to apply the merging of cells in batches as I figured doing it for all cells at once might have been what was making the code run much slower but I didn't notice any real difference in execution time.

Code below:


Sub ClearAndFormatLogTable()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Easy Mode") ' Replace with your sheet name
    
    ' Turn off ScreenUpdating and Events to improve performance
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' Clear values and formats from range A7 to J50000
    ws.Range("A7:J50000").ClearContents
    ws.Range("A7:J50000").ClearFormats
    
    ' Merge cells in the first row (row 7)
    ws.Range("C7:J7").Merge
    ws.Range("C7").HorizontalAlignment = xlCenterAcrossSelection
    
    ' Copy format from the merged cell
    ws.Range("C7").Copy
    
    ' Apply the format in batches
    Dim i As Long
    For i = 8 To 50000 Step 1000
        ws.Range("C" & i & ":J" & Application.Min(i + 999, 50000)).PasteSpecial xlPasteFormats
    Next i
    
    Application.CutCopyMode = False ' Clear the copy mode
    
    ' Apply thick borders and dotted inner vertical divisions
    With ws.Range("B7:J50000")
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlThick
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlThick
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeTop).Weight = xlThick
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlThick
        .Borders(xlInsideHorizontal).LineStyle = xlDot
        .Borders(xlInsideVertical).LineStyle = xlDot
    End With
    
    ' Turn ScreenUpdating and Events back on
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Thanks in advance!


Solution

  • Sub ClearAndFormatLogTable()
    'Counter=0  Turn off the Counter
    Counter = 1: stTime = Timer
    '....................................................................................................
        Dim ws As Worksheet
        Set ws = ThisWorkbook.Sheets("Easy Mode") ' Replace with your sheet name
        
        ' Turn off ScreenUpdating and Events to improve performance
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        ' Clear values and formats from range A7 to J50000
        ws.Range("A7:J50000").ClearContents
        ws.Range("A7:J50000").ClearFormats
        
        ' Merge cells in the first row (row 7)
        ws.Range("C7:J7").Merge
        ws.Range("C7").HorizontalAlignment = xlCenterAcrossSelection
    
        'By using fill down instead of copy paste, results are obtained in 20-30 seconds.
        With ws.Range("C7:J50000")
            .FillDown
        End With
        
        ' Apply thick borders and dotted inner vertical divisions
        With ws.Range("B7:J50000")
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlThick
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlEdgeRight).Weight = xlThick
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeTop).Weight = xlThick
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).Weight = xlThick
            .Borders(xlInsideHorizontal).LineStyle = xlDot
            .Borders(xlInsideVertical).LineStyle = xlDot
        End With
        
        ' Turn ScreenUpdating and Events back on
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    '....................................................................................................
        If Counter = 1 Then MsgBox _
        Round(Timer - stTime, 2) & " second", vbInformation, "Macro Time"
    End Sub