VBA Evaluate无法识别GSG命名区域及正则优化后无输出求助

核心问题1：特定命名引用（GSG）无法被VBA识别 #

• 现象：处理工作表公式的VBA宏可正常识别HS、KJ、TV等命名引用，但始终无法识别GSG
• 排查结果：
  • 工作表中=0.25*GSG公式可正常计算（如得出2.5），说明GSG在名称管理器中已正确定义
  • VBA通过Application.Evaluate处理时，GSG的贡献被忽略，无报错，仿佛该名称不存在
  • 将GSG改为NY等其他名称后，宏可正常工作，改回GSG则问题重现

补充问题：正则解析公式的性能与输出异常 #

• 改用正则解析公式后，宏可正确计算代码贡献，但执行时间长达20-30秒
• 尝试的优化措施：
  • 避免重复创建正则对象，用Scripting.Dictionary缓存复用
  • 优化正则匹配模式
  • 将正则处理移至循环外
• 优化后的问题：多数优化操作后，Deliveries工作表的L列无输出

宏逻辑说明 #

1. 从Calc工作表E列读取Quantity值
2. 在Calc工作表的T、Q列查找包含指定参考代码（如GSG）的公式
3. 将各代码对应的数量总和输出至Deliveries工作表的L列（代码对应C列）
4. 支持=0,5*(0,42*HS + 0,14*JB)这类带数学运算的表达式

相关代码 #

Public Sub CountWorkHours(Optional control As Variant)

    Dim wsCalc As Worksheet, wsDeliveries As Worksheet
    Set wsCalc = ThisWorkbook.Worksheets("Calc")
    Set wsDeliveries = ThisWorkbook.Worksheets("Deliveries")

    ' 1) Load all codes from the "Deliveries" sheet
    Dim codeList As Variant
    codeList = GetCodesFromDeliveries(wsDeliveries)
    If Not IsArray(codeList) Then Exit Sub

    ' 2) Reset column L for all codes
    Dim i As Long
    For i = LBound(codeList) To UBound(codeList)
        If Len(codeList(i)) > 0 Then
            Dim cell As Range
            Set cell = wsDeliveries.Range("C:C").Find(What:=codeList(i), LookIn:=xlValues, LookAt:=xlWhole)
            If Not cell Is Nothing Then
                cell.Offset(0, 9).Value = 0
            End If
        End If
    Next i

    ' 3) Create a dictionary to accumulate totals per code
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare

    ' 4) Find the last row in the "Calc" sheet based on column E
    Dim lastRow As Long
    lastRow = wsCalc.Cells(wsCalc.Rows.Count, "E").End(xlUp).Row

    ' 5) Loop through each row and process formulas
    Dim r As Long
    For r = 6 To lastRow
        Dim qty As Variant
        qty = wsCalc.Cells(r, "E").Value
        If IsEmpty(qty) Or qty = 0 Then GoTo NextRow

        Dim formQ As String, formT As String
        formQ = wsCalc.Cells(r, "Q").Formula
        formT = wsCalc.Cells(r, "T").Formula

        If Left(formQ, 1) = "=" Then formQ = Mid(formQ, 2)
        If Left(formT, 1) = "=" Then formT = Mid(formT, 2)

        If Len(Trim(formQ)) > 0 Then ProcessFullFormula formQ, codeList, dict, qty
        If Len(Trim(formT)) > 0 Then ProcessFullFormula formT, codeList, dict, qty

NextRow:
    Next r

    ' 6) Write totals back to column L based on code lookup
    Dim code As Variant
    For Each code In dict.Keys
        Set cell = wsDeliveries.Range("C:C").Find(What:=code, LookIn:=xlValues, LookAt:=xlWhole)
        If Not cell Is Nothing Then
            cell.Offset(0, 9).Value = dict(code)
        End If
    Next code

End Sub



Private Function GetCodesFromDeliveries(wsDeliveries As Worksheet) As Variant

    Dim firstRow As Long, lastRow As Long
    firstRow = 8
    lastRow = wsDeliveries.Cells(wsDeliveries.Rows.Count, "C").End(xlUp).Row
    If lastRow < firstRow Then Exit Function

    Dim arr As Variant
    arr = wsDeliveries.Range("C" & firstRow & ":C" & lastRow).Value

    Dim result() As Variant
    ReDim result(1 To UBound(arr, 1))

    Dim i As Long
    For i = 1 To UBound(arr, 1)
        result(i) = Trim(arr(i, 1))
    Next i

    GetCodesFromDeliveries = result

End Function

Private Sub ProcessFullFormula(formulaStr As String, _
                               ByVal codeList As Variant, _
                               ByVal dict As Object, _
                               ByVal qty As Double)

    Dim baseFormula As String
    baseFormula = Replace(formulaStr, ",", ".") ' Use dot for Evaluate compatibility

    Dim totalValue As Double, baseValue As Double
    Dim codeFormula As String, codeContribution As Double
    Dim code As Variant, otherCode As Variant

    ' 1) Evaluate total formula (all codes = 1)
    Dim fullFormula As String
    fullFormula = ReplaceCodeTokens(baseFormula, codeList, "1")

    On Error Resume Next
    totalValue = Application.Evaluate(fullFormula)
    On Error GoTo 0
    If IsError(totalValue) Or IsEmpty(totalValue) Then Exit Sub

    ' 2) Evaluate base formula (all codes = 0)
    Dim zeroFormula As String
    zeroFormula = ReplaceCodeTokens(baseFormula, codeList, "0")

    On Error Resume Next
    baseValue = Application.Evaluate(zeroFormula)
    On Error GoTo 0
    If IsError(baseValue) Or IsEmpty(baseValue) Then Exit Sub

    Dim delta As Double
    delta = totalValue - baseValue
    If Abs(delta) < 0.000001 Then Exit Sub

    ' 3) Calculate contribution for each individual code
    For Each code In codeList
        If Len(code) > 0 Then
            codeFormula = baseFormula
            For Each otherCode In codeList
                If Len(otherCode) > 0 Then
                    Dim replacementValue As String
                    If otherCode = code Then
                        replacementValue = "1"
                    Else
                        replacementValue = "0"
                    End If

                    Dim regex As Object
                    Set regex = CreateObject("VBScript.RegExp")
                    regex.IgnoreCase = True
                    regex.Global = True
                    regex.Pattern = "(^|[^A-Za-z0-9])(" & otherCode & ")(?=$|[^A-Za-z0-9])"
                    codeFormula = regex.Replace(codeFormula, "$1" & replacementValue)
                End If
            Next otherCode

            On Error Resume Next
            codeContribution = Application.Evaluate(codeFormula) - baseValue
            On Error GoTo 0

            If Abs(codeContribution) > 0.000001 Then
                If Not dict.Exists(code) Then dict(code) = 0
                dict(code) = dict(code) + (codeContribution * qty)
            End If
        End If
    Next code

End Sub

Private Function ReplaceCodeTokens(formulaStr As String, codeList As Variant, substituteValue As String) As String
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.IgnoreCase = True
    regex.Global = True

    Dim code As Variant
    For Each code In codeList
        If Len(code) > 0 Then
            regex.Pattern = "(^|[^A-Za-z0-9])(" & code & ")(?=$|[^A-Za-z0-9])"
            formulaStr = regex.Replace(formulaStr, "$1" & substituteValue)
        End If
    Next code

    ReplaceCodeTokens = formulaStr
End Function

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