We encountered a strange issue in Excel where a VBA macro was supposed to process formulas from a worksheet and identify named references (such as GSG) to distribute quantities accordingly. While the macro worked perfectly for most named references (e.g., HS, KJ, TV, etc.), it consistently failed to recognize and calculate values for a specific name: GSG.

Upon investigation, we found the following: (From various debugging scripts)

The formula =0.25*GSG was correctly written in the sheet, and it evaluated without errors directly in Excel (producing the correct value, e.g., 2.5), meaning the name GSG was defined and recognized in Excel’s Name Manager.

However, in VBA, when processing formulas via Application.Evaluate, the contribution from GSG was always ignored, as if the name didn't exist. No errors were raised — the formula simply contributed nothing in the macro logic.

Changing the name GSG to something else, like NY, and updating both Name Manager and the formula accordingly made everything work perfectly in the macro. The VBA logic correctly evaluated the formula and distributed the amount.

We then tried switching back to GSG, and the problem reappeared — even though GSG was visible and working in Excel formulas, it was once again ignored by the macro.

Honestly, I'm confused. Anyone have any idea why our workbook is behaving like this?

EDIT:

We successfully got regex-based formula parsing to work, meaning the macro now correctly evaluates and distributes code-based contributions. However, the issue is now performance - execution time is around 20-30 seconds due to repeated regex creation and inefficient replacements.

What we tried to make it faster.

• try to avoid repeated regex object creation
• Instead of creating a new regex object for each replacement, we cache regex objects using a dictionary for reuse.
• refined regex pattern matching
• tried moving Regex Processing Outside of Loops

With most of these optimizations, however, I ran into the code not outputting anything in the preferred L column.

How the code works:

1. Searches column E in Calc for the Quantity
2. Then searches column T and Q for formulas related to specific reference codes (E.g. GSG)
3. Output the summed total of quanity related to each reference code in "Deliveries" (Output column is L, reference codes are placed in column C)
4. Handles various math expressions like =0,5*(0,42HS + 0,14JB)

"Calc" sheet - contains raw calculation data, including quantity and formulas.

"Deliveries" sheet - contains a list of delivery codes and a column to store accumulated results.

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