How to loop over conditions in countifs formula VBA

Question

I have an Excel worksheet with a column full of COUNTIFS() formulas. For each one that evaluates to zero, I have to manually apply filters on the appropriate columns to find out at which step in the formula the result reached zero. What I want to do is write a macro to automate this a bit. For instance:

 =COUNTIFS('Data'!A:A,"Yes",'Data'!B:B,"Yes",'Data'!C:C,"Yes")

If the count becomes zero as soon as the first condition is evaluated, I want it to MsgBox a value of 1. If it becomes zero upon evaluating the second condition, return a 2 instead. If it doesn't hit zero until adding the third condition, I want it to return a 3 instead, and so on.

For the sake of simplicity, assume it only has to work for one cell , rather than looping through each cell in my column.

EDIT: Here is the code I've written so far. It will take a COUNTIFS() formula and run the first condition as a COUNTIF(), but I haven't been able to think of how to extend this to also do the later conditions.

            'Find Indexes
            countifsStart = InStr(1, cell.Formula, "COUNTIFS(")
            sheetNameStart = InStr(countifsStart, cell.Formula, "(") + 2
            sheetNameEnd = InStr(sheetNameStart, cell.Formula, "'")
            searchRangeStart = InStr(sheetNameEnd, cell.Formula, "!") + 1
            searchRangeSemicolon = InStr(searchRangeStart, cell.Formula, ":")
            searchStringStart = InStr(searchRangeSemicolon, cell.Formula, ",") + 2
            searchStringEnd = InStr(searchStringStart, cell.Formula, ",") - 1

            'Parse formula components
            sheetName = Mid(cell.Formula, sheetNameStart, sheetNameEnd - sheetNameStart)
            searchColumn = Mid(cell.Formula, searchRangeStart, 1)
            Set searchRange = Range(searchColumn & ":" & searchColumn)
            searchString = Mid(cell.Formula, searchStringStart, searchStringEnd - searchStringStart)

            'Run the countif
            countIf = Application.WorksheetFunction.countIf(Sheets(sheetName).Range(searchColumn & ":" & searchColumn), searchString)

            'Point out the culprit
            MsgBox "Sheet Name: " & sheetName & vbNewLine & _
                   "Search Range: " & searchColumn & ":" & searchColumn & vbNewLine & _
                   "Search String: " & searchString & vbNewLine & _
                   "CountIf: " & countIf

Answer 1

Perhaps something like this will work for you:

Sub tgr()

    Dim rFormula As Range
    Dim hArguments As Object
    Dim sArguments As String
    Dim sMessage As String
    Dim sTemp As String
    Dim sChar As String
    Dim lFunctionStart As Long
    Dim lParensPairs As Long
    Dim lQuotePairs As Long
    Dim bArgumentEnd As Boolean
    Dim i As Long, j As Long

    Set hArguments = CreateObject("Scripting.Dictionary")

    For Each rFormula In Selection.Cells
        lFunctionStart = InStr(1, rFormula.Formula, "COUNTIFS(", vbTextCompare)
        If lFunctionStart > 0 Then
            lFunctionStart = lFunctionStart + 9
            lParensPairs = 1
            lQuotePairs = 0
            j = 0
            bArgumentEnd = False
            For i = lFunctionStart To Len(rFormula.Formula)
                sChar = Mid(rFormula.Formula, i, 1)
                Select Case sChar
                    Case "'", """"
                        If lQuotePairs = 0 Then
                            lQuotePairs = lQuotePairs + 1
                        Else
                            lQuotePairs = lQuotePairs - 1
                        End If
                        sTemp = sTemp & sChar

                    Case "("
                        If lQuotePairs = 0 Then
                            lParensPairs = lParensPairs + 1
                        End If
                        sTemp = sTemp & sChar

                    Case ")"
                        If lQuotePairs = 0 Then
                            lParensPairs = lParensPairs - 1
                            If lParensPairs = 0 Then
                                j = j + 1
                                hArguments(j) = sTemp
                                sTemp = vbNullString
                                Exit For
                            Else
                                sTemp = sTemp & sChar
                            End If
                        Else
                            sTemp = sTemp & sChar
                        End If

                    Case ","
                        If lQuotePairs = 0 And lParensPairs = 1 Then
                            bArgumentEnd = True
                            j = j + 1
                            hArguments(j) = sTemp
                            sTemp = vbNullString
                        Else
                            sTemp = sTemp & sChar
                        End If

                    Case Else
                        sTemp = sTemp & sChar

                End Select
            Next i
            For i = 1 To hArguments.Count Step 2
                If Len(sArguments) = 0 Then
                    sArguments = hArguments(i) & "," & hArguments(i + 1)
                Else
                    sArguments = sArguments & "," & hArguments(i) & "," & hArguments(i + 1)
                End If
                If Evaluate("COUNTIFS(" & sArguments & ")") = 0 Then
                    MsgBox "Search Range: " & hArguments(i) & Chr(10) & _
                           "Search String: " & hArguments(i + 1) & Chr(10) & _
                           "Countif condition position: " & Int(i / 2) + 1
                    Exit For
                End If
            Next i
        End If
    Next rFormula

End Sub

Answer 2

Posting just as an alternative method to get at the arguments (which I found in another answer elsewhere by Peter Thornton)

Private args()

Sub Tester()
    Debug.Print GetZeroStep(Range("M1"))
End Sub


Function GetZeroStep(c As Range)

    Dim f, arr, i, r, s, n, rng, v
    f = Replace(c.Formula, "=COUNTIFS(", "=MyUDFTmp(")

    Debug.Print f
    r = Application.Evaluate(f)


    For i = 0 To UBound(args) Step 2
        n = n + 1
        Set rng = args(i)
        v = args(i + 1)
        If Not IsNumeric(v) Then v = """" & v & """"
        s = s & IIf(s <> "", ",", "") & "'" & rng.Parent.Name & "'!" & _
                                         rng.Address() & "," & v
        Debug.Print "=COUNTIFS(" & s & ")"
        r = Application.Evaluate("=COUNTIFS(" & s & ")")
        If r = 0 Then
            GetZeroStep = n
            Exit Function
        End If
    Next i
    GetZeroStep = 0 '<< didn't return zero on any step...
End Function

'https://social.msdn.microsoft.com/Forums/Lync/en-US/8c52aee1-5168-4909-9c6a-9ea790c2baca/get-formula-arguments-in-vba?forum=exceldev
Public Function MyUDFTmp(ParamArray arr())
   args() = arr
End Function