Question

我有一个Excel工作表，其中包含COUNTIFS（）个公式。对于每个求值为零的值，我必须在适当的列上手动应用过滤器，以找出公式中哪一步达到了零。我想要做的是编写一个宏来使其自动化。例如：

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

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

为简单起见，假设它只适用于一个单元格，而不是遍历我列中的每个单元格。

编辑：这是我到目前为止编写的代码。它需要一个COUNTIFS（）公式并将 first 条件作为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

张贴文章作为获取论点的另一种方法（我在彼得·桑顿的其他答案中找到了该观点）

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

如何遍历Countifs公式VBA中的条件

2 个答案: