为符合条件单元格添加自适应公式的VBA代码调试求助

问题背景 #

需要在D43:ZZ1000区域内，仅对满足以下两个条件的单元格填充复杂公式：

• 对应行的C列单元格不为空
• 对应列的第6行单元格不为空

直接批量填充公式会导致文件体积从5MB激增到60MB以上，工作簿无法正常使用，因此需要自适应填充的VBA代码。本人仅掌握基础VBA知识，自行编写的代码无法调试，原代码如下：

Sub Formula_CF()
'
Dim Col_Rng As Range
Col_Rng = Range("D5:ZZ5")
Dim Row_Rng As Range
Row_Rng = Range("A43:A1000")
Dim Date_Rng As Range
Date_Rng = Range("D6:ZZ6")
Dim Name_Rng As Range
Name_Rng = Range("B43:B1000")
'
Dim Start As Range
Start = Range("D43")
Dim Finish As Range
Finish = Range("ZZ1000")
'
If Date_Rng <> "" And Name_Rng <> "" Then
    Range(Start) = _
        "=IF(" & Col_Rng & "$6<>" & """" & "," & _
        "SUMIFS(Sheet1!$EO:$EO,Sheet1!$G:$G,Sheet2!$C" & Row_Rng & ",Sheet1!$EN:$EN,Sheet2!" & Date_Rng & "$6)+" & _
        "SUMIFS(Sheet1!$EQ:$EQ,Sheet1!$G:$G,Sheet2!$C" & Row_Rng & ",Sheet1!$EP:$EP,Sheet2!" & Date_Rng & "$6)+" & _
        "SUMIFS(Sheet1!$ES:$ES,Sheet1!$G:$G,Sheet2!$C" & Row_Rng & ",Sheet1!$ER:$ER,Sheet2!" & Date_Rng & "$6)+" & _
        "SUMIFS(Sheet1!$EU:$EU,Sheet1!$G:$G,Sheet2!$C" & Row_Rng & ",Sheet1!$ET:$ET,Sheet2!" & Date_Rng & "$6),"""
End If
'
End Sub

修正后的代码 #

Sub AdaptiveFormulaFill()
    Dim targetCell As Range
    Dim targetRange As Range
    Dim rowCheckCell As Range
    Dim colCheckCell As Range
    
    ' 定义目标区域（指定Sheet2，可根据实际修改）
    Set targetRange = ThisWorkbook.Sheets("Sheet2").Range("D43:ZZ1000")
    
    ' 关闭屏幕更新，提升运行速度
    Application.ScreenUpdating = False
    
    ' 遍历目标区域每个单元格
    For Each targetCell In targetRange
        ' 获取对应行的C列单元格
        Set rowCheckCell = targetCell.EntireRow.Columns("C")
        ' 获取对应列的第6行单元格
        Set colCheckCell = targetCell.EntireColumn.Rows(6)
        
        ' 检查两个条件是否满足
        If Not IsEmpty(rowCheckCell) And Not IsEmpty(colCheckCell) Then
            ' 动态生成公式，拼接正确的单元格引用
            targetCell.Formula = "=IF(" & colCheckCell.Address(False, False) & "<>""""," & _
                                "SUMIFS(Sheet1!$EO:$EO,Sheet1!$G:$G,Sheet2!" & rowCheckCell.Address(False, False) & _
                                ",Sheet1!$EN:$EN,Sheet2!" & colCheckCell.Address(False, False) & ")+" & _
                                "SUMIFS(Sheet1!$EQ:$EQ,Sheet1!$G:$G,Sheet2!" & rowCheckCell.Address(False, False) & _
                                ",Sheet1!$EP:$EP,Sheet2!" & colCheckCell.Address(False, False) & ")+" & _
                                "SUMIFS(Sheet1!$ES:$ES,Sheet1!$G:$G,Sheet2!" & rowCheckCell.Address(False, False) & _
                                ",Sheet1!$ER:$ER,Sheet2!" & colCheckCell.Address(False, False) & ")+" & _
                                "SUMIFS(Sheet1!$EU:$EU,Sheet1!$G:$G,Sheet2!" & rowCheckCell.Address(False, False) & _
                                ",Sheet1!$ET:$ET,Sheet2!" & colCheckCell.Address(False, False) & "),"""")"
        Else
            ' 不满足条件则清空单元格
            targetCell.ClearContents
        End If
    Next targetCell
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    
    MsgBox "公式填充完成！"
End Sub

关键修正说明 #

1. 变量赋值修正：使用Set关键字正确为Range对象赋值，解决原代码编译错误
2. 遍历逻辑优化：逐单元格检查条件，仅对符合要求的单元格填充公式，避免无效公式占用文件空间
3. 动态引用处理：通过Address方法获取对应检查单元格的相对引用，确保公式引用精准
4. 性能提升：关闭ScreenUpdating减少界面刷新次数，大幅提升代码运行速度
5. 公式语法修复：修正原代码字符串拼接的引号错误，保证公式语法合法

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