如何在countifs公式VBA中循环条件

Question

我有一个Excel工作表，其中包含一个充满COUNTIFS（）公式的列。对于评估为零的每个，我必须在适当的列上手动应用过滤器，以找出公式中结果达到零的步骤。我想要做的是写一个宏来自动化这一点。例如：

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

如果在计算第一个条件后计数变为零，我希望MsgBox的值为1.如果在评估第二个条件时它变为零，则返回2。如果在添加第三个条件之前它没有达到零，我希望它返回3，依此类推。

为简单起见，假设它只需要为一个单元格工作，而不是循环遍历列中的每个单元格。

编辑：这是我到目前为止编写的代码。它将采用COUNTIFS（）公式并将第一个条件作为COUNTIF（）运行，但是我还没有想到如何扩展它以适应后面的条件。

            '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

也许这样的事情对你有用：

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

发布作为获取参数的替代方法（我在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