VBA日志清理宏执行过慢，如何优化提升运行速度？

我写了一个VBA宏用来清除日志内容并重新格式化表格，功能正常但运行要30分钟，期间Excel完全冻住没法操作。看任务管理器发现Excel只占用约12.5%的处理器资源，想知道能不能通过多线程或者代码优化缩短运行时间？之前试过批量合并单元格，执行时间没明显改善，宏代码如下：

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

VBA本身是单线程环境，没法直接实现多线程并行处理，但通过代码优化可以把运行时间压缩到几秒级别，核心是减少高开销操作、关闭Excel额外消耗项：

关键优化点 #

• 移除循环粘贴格式操作：直接对整个目标范围批量设置合并和对齐，复制粘贴本身是高开销操作，循环多次会大幅拖慢速度
• 合并清除操作：用Clear替代ClearContents+ClearFormats，一次完成内容和格式清除
• 关闭自动计算：格式变更会触发Excel自动计算，手动关闭可避免不必要的资源消耗
• 关闭警告弹窗：合并单元格时的弹窗会中断执行，提前关闭能提升流畅度
• 简化边框设置：通过统一调用Borders对象减少重复的Range访问

优化后的代码 #

Sub ClearAndFormatLogTable()
    Dim ws As Worksheet
    Dim targetRange As Range
    Dim mergeRange As Range
    
    Set ws = ThisWorkbook.Sheets("Easy Mode")
    Set targetRange = ws.Range("A7:J50000")
    Set mergeRange = ws.Range("C7:J50000")
    
    ' 关闭所有非必要的Excel功能，最大化性能
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    
    ' 一次性清除内容和格式，替代两次单独操作
    targetRange.Clear
    
    ' 批量设置合并单元格和对齐方式，无需复制粘贴
    With mergeRange
        .MergeCells = True
        .HorizontalAlignment = xlCenterAcrossSelection
    End With
    
    ' 统一设置边框样式，减少重复对象调用
    With ws.Range("B7:J50000").Borders
        ' 设置外框粗线
        .Item(xlEdgeLeft).LineStyle = xlContinuous
        .Item(xlEdgeLeft).Weight = xlThick
        .Item(xlEdgeRight).LineStyle = xlContinuous
        .Item(xlEdgeRight).Weight = xlThick
        .Item(xlEdgeTop).LineStyle = xlContinuous
        .Item(xlEdgeTop).Weight = xlThick
        .Item(xlEdgeBottom).LineStyle = xlContinuous
        .Item(xlEdgeBottom).Weight = xlThick
        ' 设置内框虚线
        .Item(xlInsideHorizontal).LineStyle = xlDot
        .Item(xlInsideVertical).LineStyle = xlDot
    End With
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
End Sub

效果说明 #

优化后代码避免了循环复制粘贴的高开销操作，同时关闭了自动计算等额外消耗，运行时间会从30分钟大幅缩短到几秒，Excel也不会出现冻结情况。如果要进一步提升，还可以考虑只处理有数据的行（而非固定到50000行），但当前代码已经能解决核心性能问题。

内容的提问来源于stack exchange，提问作者Ricardo Barrera Villarreal