VBA调用Evaluate执行XLOOKUP返回#WERT!错误求助

问题描述 #

尝试用VBA代码填充表格空白单元格，需4个条件匹配数据，目前仅实现前3个条件。直接将生成的公式字符串粘贴到Excel中能得到正确结果，但代码运行后返回#WERT!（德语版#VALUE!）错误，需排查问题。

条件定义 #

Criteria1 = WS.Cells(row1, 4)
Criteria2 = "All Property"
Criteria3 = WS.Cells(row1, 6)
Criteria4 = WS.Cells(3, col1)

现有VBA代码 #

Sub TEST_123()

Dim WB As Workbook
Dim WS As Worksheet
Dim WS2 As Worksheet
Set WB = ActiveWorkbook
Set WS = WB.Sheets("BASIS")
Set WS2 = WB.Sheets("TEST")

Dim arr As Variant
Dim lastrow As Integer

lastrow = WS.Range("D" & WS.Rows.Count).End(xlUp).Row

Dim arrResults() As Variant
Dim Dimension1 As Long, row1 As Long
       
arr = WS.Range("A1:AC" & lastrow)

Dimension1 = UBound(arr, 1)

ReDim arrResults(1 To Dimension1, 1 To 22)
    
Dim str As String

Application.ScreenUpdating = False

       
    For row1 = 1 To Dimension1
    
        If WS.Cells(row1, 8) = "" Then
        
            str = "=XLOOKUP(" & WS.Cells(row1, 4).Address(, , , 1) & "&" & WS.Cells(3, 5).Address(, , , 1) & "&" & WS.Cells(row1, 6).Address(, , , 1) & ";"
            str = str & WS.Range("D1:D" & lastrow).Address(, , , 1) & "&" & WS.Range("E1:E" & lastrow).Address(, , , 1) & "&" & WS.Range("F1:F" & lastrow).Address(, , , 1) & ";"
            str = str & WS.Range("H1:H" & lastrow).Address(, , , 1) & ")"

            arrResults(row1, 1).Formula = Application.Evaluate(str)
            'Debug.Print str
                    
            Else: WS2.Cells(row1, 1) = WS.Cells(row1, 8)

         End If
    Next row1

WS2.Range("A1:A" & lastrow) = arrResults

End Sub

问题分析与解决方案 #

核心错误点 #

1. 数组元素无Formula属性：arrResults是内存中的Variant数组，不存在.Formula属性，直接赋值会触发错误。应将Application.Evaluate(str)的计算结果直接存入数组，或直接在工作表单元格写入公式。
2. 未实现第四个条件匹配：现有公式仅拼接了前3个条件，未加入Criteria4的匹配逻辑。
3. 循环逻辑不一致：Else分支直接写入WS2.Cells，但If分支通过数组赋值，导致最终数组中部分值未被正确填充。

修正后的代码 #

Sub TEST_123_FIXED()
    Dim WB As Workbook
    Dim WS As Worksheet, WS2 As Worksheet
    Dim lastrow As Long, row1 As Long
    Dim str As String
    Dim arrResults() As Variant
    
    Set WB = ActiveWorkbook
    Set WS = WB.Sheets("BASIS")
    Set WS2 = WB.Sheets("TEST")
    
    lastrow = WS.Range("D" & WS.Rows.Count).End(xlUp).Row
    ReDim arrResults(1 To lastrow, 1 To 1) '仅需1列存储结果
    
    Application.ScreenUpdating = False
    
    For row1 = 1 To lastrow
        If WS.Cells(row1, 8).Value = "" Then
            '替换为实际Criteria4对应的列，示例用G列
            Dim criteria4Addr As String
            criteria4Addr = WS.Cells(3, "G").Address(, , , 1)
            
            '拼接包含4个条件的XLOOKUP公式
            str = "=XLOOKUP(" & WS.Cells(row1, 4).Address(, , , 1) & "&" & _
                  WS.Cells(3, 5).Address(, , , 1) & "&" & _
                  WS.Cells(row1, 6).Address(, , , 1) & "&" & _
                  criteria4Addr & ";" & _
                  WS.Range("D1:D" & lastrow).Address(, , , 1) & "&" & _
                  WS.Range("E1:E" & lastrow).Address(, , , 1) & "&" & _
                  WS.Range("F1:F" & lastrow).Address(, , , 1) & "&" & _
                  WS.Range("G1:G" & lastrow).Address(, , , 1) & ";" & _
                  WS.Range("H1:H" & lastrow).Address(, , , 1) & ")"
            
            '将计算结果存入数组
            arrResults(row1, 1) = Application.Evaluate(str)
        Else
            '将非空值存入数组
            arrResults(row1, 1) = WS.Cells(row1, 8).Value
        End If
    Next row1
    
    '一次性写入结果到工作表
    WS2.Range("A1:A" & lastrow).Value = arrResults
    
    Application.ScreenUpdating = True
End Sub

关键调整说明 #

• 移除不必要的arr变量，简化逻辑。
• 统一用数组存储所有结果，避免循环中直接操作工作表导致的效率损耗。
• 加入第四个条件的拼接逻辑，需将代码中WS.Cells(3, "G")和WS.Range("G1:G" & lastrow)替换为实际Criteria4对应的列。
• 直接将Application.Evaluate(str)的结果存入数组，规避数组属性错误。
• 恢复Application.ScreenUpdating = True，确保界面正常刷新。

内容的提问来源于stack exchange，提问作者Elisa R.