Блог

У меня есть рабочий лист 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 amp; ":" amp; searchColumn)
            searchString = Mid(cell.Formula, searchStringStart, searchStringEnd - searchStringStart)

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

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

Возможно, что-то подобное сработает для вас:

 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 amp; sChar

                    Case "("
                        If lQuotePairs = 0 Then
                            lParensPairs = lParensPairs   1
                        End If
                        sTemp = sTemp amp; 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 amp; sChar
                            End If
                        Else
                            sTemp = sTemp amp; sChar
                        End If

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

                    Case Else
                        sTemp = sTemp amp; sChar

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

End Sub
  

Публикация просто как альтернативный метод для получения аргументов (который я нашел в другом ответе в другом месте Питера Торнтона)

 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 = """" amp; v amp; """"
        s = s amp; IIf(s <> "", ",", "") amp; "'" amp; rng.Parent.Name amp; "'!" amp; _
                                         rng.Address() amp; "," amp; v
        Debug.Print "=COUNTIFS(" amp; s amp; ")"
        r = Application.Evaluate("=COUNTIFS(" amp; s amp; ")")
        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