Excel VBA优化：仅为空白单元格写入公式（规避Select低效操作）

我需要在Excel中用VBA仅给空白单元格写入公式，同时避免使用Select操作来提升代码效率。之前的代码是批量清除指定列、写入公式再转成值，但现在需求调整为：只清除部分列，且仅向空白单元格添加公式。我自己写了一段测试代码，想知道有没有更高效的实现方式。

现有代码 #

'clean out the entries in F:F
Worksheets("Bar Details").Range("f3:f425").ClearContents

'clean out row numbers and styles
Worksheets("Bar Details").Range("g3:h330").ClearContents

'clean out above / below
Worksheets("Bar Details").Range("j3:k302").ClearContents

'enter a "y" against any row with a number in the input data
With Worksheets("Bar Details").Range("d3:d302")
    .FormulaR1C1 = "=if(iserror(vlookup(rc1,Auto_Calc_rows,1,false)),"""",""y"")"
    .Calculate
End With
'Worksheets("Bar Details").Range("d3:d302").Value = Worksheets("Bar Details").Range("d3:d302").Value

'enter the names into E:E
With Worksheets("Bar Details").Range("e3:e302")
    .FormulaR1C1 = "=if(rc4="""","""",trim(vlookup(rc1,task_details_lookup,2,false)))"
    .Calculate
End With
'Worksheets("Bar Details").Range("e3:e302").Value = Worksheets("Bar Details").Range("e3:e302").Value ' suspect

'enter name in F:F unless it is a milestone
With Worksheets("Bar Details").Range("f3:f302")
    .FormulaR1C1 = "=if(rc4="""","""",IF(VLOOKUP(rc1,MS_Data,9,FALSE)=""y"","""",rc5))"  'IF(VLOOKUP(rc1,MS_Data,9,FALSE)="y","",rc5)
    .Calculate
End With

'enter vlooklup against original data to pull the rows across
With Worksheets("Bar Details").Range("g3:g302") 
    .FormulaR1C1 = "=if(rc4="""","""",vlookup(rc1,Auto_Calc_rows,7,false))"
    .Calculate
End With

'wipe out all the calculations
Worksheets("Bar Details").Range("d3:g302").Value = Worksheets("Bar Details").Range("d3:g302").Value

测试代码 #

Sub test_blank_replacement()

TestOverWrite = MsgBox("Do you want to replace all existing data?" & vbCr & " " & vbCr & _
    "Please select 'No' if you have previously used similar data" & vbCr & "Selecting 'Yes' will replace all data" & vbCr & "  " _
    , vbQuestion + vbYesNo + vbDefaultButton1, "Options")

On Error Resume Next
With ActiveSheet.Range("A1:A10")
    If TestOverWrite = vbYes Then
        .ClearContents
        .FormulaR1C1 = "=RC4"
        .Calculate
        .Value = .Value
    Else
        .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=RC3"
        .Calculate
        .Value = .Value
    End If
End With

MsgBox "all done"
End Sub

高效实现方案建议 #

1. 减少重复对象调用，批量处理逻辑 #

提前定义工作表对象，避免重复调用Worksheets("Bar Details")；将多列的公式与范围整合为数组，通过循环批量处理，减少冗余代码。

2. 关闭屏幕刷新与事件触发 #

在代码开头添加以下两行，结尾恢复设置，大幅提升大范围内操作的速度：

Application.ScreenUpdating = False
Application.EnableEvents = False
' 代码执行完成后恢复
Application.ScreenUpdating = True
Application.EnableEvents = True

3. 避免多余的Calculate调用 #

不需要单独调用.Calculate，执行.Value = .Value时Excel会自动计算并转换公式为值，省去额外步骤。

4. 严谨处理无空白单元格的异常 #

SpecialCells(xlCellTypeBlanks)找不到空白单元格时会报错，用以下方式替代On Error Resume Next的模糊处理：

Dim blankCells As Range
On Error Resume Next
Set blankCells = .SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not blankCells Is Nothing Then
    blankCells.FormulaR1C1 = "=RC3"
    blankCells.Value = blankCells.Value
End If

5. 针对需求的优化示例代码 #

Sub OptimizedUpdate()
    Dim ws As Worksheet
    Dim targetRanges As Variant
    Dim i As Integer
    
    ' 初始化加速设置
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set ws = Worksheets("Bar Details")
    
    ' 清除指定列内容
    ws.Range("f3:f425").ClearContents
    ws.Range("g3:h330").ClearContents
    ws.Range("j3:k302").ClearContents
    
    ' 定义需要处理的列及对应公式
    targetRanges = Array( _
        Array("d3:d302", "=if(iserror(vlookup(rc1,Auto_Calc_rows,1,false)),"""",""y"")"), _
        Array("e3:e302", "=if(rc4="""","""",trim(vlookup(rc1,task_details_lookup,2,false)))"), _
        Array("f3:f302", "=if(rc4="""","""",IF(VLOOKUP(rc1,MS_Data,9,FALSE)=""y"","""",rc5))"), _
        Array("g3:g302", "=if(rc4="""","""",vlookup(rc1,Auto_Calc_rows,7,false))") _
    )
    
    ' 批量处理每一列的空白单元格
    For i = LBound(targetRanges) To UBound(targetRanges)
        With ws.Range(targetRanges(i)(0))
            Dim blanks As Range
            On Error Resume Next
            Set blanks = .SpecialCells(xlCellTypeBlanks)
            On Error GoTo 0
            
            If Not blanks Is Nothing Then
                blanks.FormulaR1C1 = targetRanges(i)(1)
                blanks.Value = blanks.Value
            End If
        End With
    Next i
    
    ' 恢复设置并提示完成
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox "处理完成"
End Sub

6. 动态获取最后一行（可选） #

如果数据行数不固定，用以下代码动态获取最后一行，避免硬编码行号：

Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

内容的提问来源于stack exchange，提问作者Miles