Excel VBA数据填充宏运行异常及功能优化咨询

现有VBA代码运行不符合预期，待修复问题共3项：

• DATADB工作表的QTY列原本存储QTY1、QTY2列数值相乘的计算公式，宏运行后原有公式被覆盖为静态值，要求宏执行后QTY列保留原有计算公式
• 若DATADB工作表CODE列存在空值，宏运行后对应行填充结果应为空，当前版本会残留上一次宏执行生成的旧数据
• 宏当前绑定快捷键为Ctrl+Shift+S，要求快捷键触发宏时，代码仅在当前正在操作的活动工作表上运行

原有问题代码 #

Public Sub FillData()
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("DBMASTER")
        Dim Source() As Variant
        Source = .Range("C1").CurrentRegion.Offset(, 0).Resize(, 6).Value2
    End With
    
    Dim Dic As Object
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbBinaryCompare
    
    Dim n As Long
    For n = 2 To UBound(Source, 1)
        Dic(Source(n, 1)) = n
    Next n
    
    With ThisWorkbook.Worksheets("DATADB")
        Dim Ary() As Variant
        Ary = .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)).Value2
        
        Dim DataRange As Range
        Set DataRange = .Range("C2").Resize(UBound(Ary), 5)
        
        Dim Nary() As Variant  ' read existing data
        Nary = DataRange.Value2
        
        For n = 1 To UBound(Ary)
             If Dic.Exists(Ary(n, 1)) Then
                Nary(n, 1) = Source(Dic(Ary(n, 1)), 2)
                Nary(n, 3) = Source(Dic(Ary(n, 1)), 4)
                Nary(n, 5) = Source(Dic(Ary(n, 1)), 3)
            End If
        Next n
        
        DataRange.Value2 = Nary
    End With
    
    Application.ScreenUpdating = True
End Sub

工作表结构参考 #

DATADB表字段 #

DBMASTER数据源表字段 #

修复后代码 #

对应三个问题的修复逻辑：

1. 拆分数据写入范围，跳过QTY所在的D列，写入操作不触碰该列，保留原有公式
2. 遍历行时，若CODE为空或匹配不到数据源，直接清空对应行的填充字段，清除历史残留数据
3. 将原代码固定引用DATADB工作表的逻辑改为引用当前活动工作表，满足快捷键触发时仅在当前操作表运行的要求

Public Sub FillData()
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    ' 读取DBMASTER固定数据源
    With ThisWorkbook.Worksheets("DBMASTER")
        Dim Source() As Variant
        Source = .Range("C1").CurrentRegion.Resize(, 6).Value2
    End With
    
    Dim Dic As Object
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbBinaryCompare
    
    Dim n As Long
    For n = 2 To UBound(Source, 1)
        Dic(CStr(Source(n, 1))) = n
    Next n
    
    ' 操作当前活动工作表
    With ActiveSheet
        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        If lastRow < 2 Then GoTo Finish
        
        Dim Ary() As Variant
        Ary = .Range("B2:B" & lastRow).Value2
        
        ' 拆分写入范围，跳过D列（QTY列）避免覆盖公式
        ' 范围1：C列（DESCRIPTION）、E列（UNIT1）
        Dim DataRange1 As Range, Nary1() As Variant
        Set DataRange1 = .Range("C2:C" & lastRow).Resize(, 2)
        Nary1 = DataRange1.Value2
        
        ' 范围2：G列（PRICE1）
        Dim DataRange2 As Range, Nary2() As Variant
        Set DataRange2 = .Range("G2:G" & lastRow)
        Nary2 = DataRange2.Value2
        
        For n = 1 To UBound(Ary)
            Dim currentCode As String
            currentCode = CStr(Ary(n, 1))
            ' 无有效CODE时清空对应字段，清除旧数据残留
            If currentCode = "" Or Not Dic.Exists(currentCode) Then
                Nary1(n, 1) = ""
                Nary1(n, 2) = ""
                Nary2(n, 1) = ""
            Else
                ' 匹配到CODE时填充对应数据
                Nary1(n, 1) = Source(Dic(currentCode), 2)
                Nary1(n, 2) = Source(Dic(currentCode), 4)
                Nary2(n, 1) = Source(Dic(currentCode), 3)
            End If
        Next n
        
        ' 批量写入数据，全程不操作D列
        DataRange1.Value2 = Nary1
        DataRange2.Value2 = Nary2
    End With

Finish:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

补充：如果需要避免在结构不匹配的工作表上误运行，可以在操作ActiveSheet前增加表结构校验逻辑，判断必填列是否存在再执行后续填充。

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