Как зациклить условия в выражениях формулы VBA - PullRequest
Новая
       16

Как зациклить условия в выражениях формулы VBA

0 голосов
/ 02 апреля 2019

У меня есть лист 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

Ответы [ 2 ]

0 голосов
/ 03 апреля 2019

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

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
0 голосов
/ 02 апреля 2019

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

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
...