CountIF в массиве VBA - PullRequest
Новая
       15

CountIF в массиве VBA

0 голосов
/ 15 мая 2019

Это должно быть легко, и я думаю, что я почти там. Я хотел бы посчитать, сколько раз запись повторяется в пределах определенного массива. Массив будет заполнен из диапазона. В конце концов, если число счетчиков больше 4, я хотел бы вставить «Excess», в противном случае, если меньше 4, я хотел бы вставить «достаточный», иначе «complete». К сожалению, несмотря на то, что я научился выполнять эти вычисления без использования массивов, при переключении на массивы возникают некоторые трудности.

Как должен выглядеть код 

Sub test()
    Dim MyArray() As Variant, Countarrays() As Variant, Result() As Variant
    Dim r As Range
    Dim rows As Integer

    Worksheets("Sheet1").Activate
    Set r = Range("B2", Range("B1").End(xlDown))
    MyArray = Range("B2", Range("B1").End(xlDown))
    rows = Range("B2", Range("B1").End(xlDown)).Count

    For i = 0 To rows
        For j = 0 To rows
        Countarrays(i, 1) = WorksheetFunction.CountIf(r, MyArray(i))

        If (Countarrays(i, 1).value) > 4 Then Result(j, 1) = "Excess"
        ElseIf (Countarrays(i, 1).value) < 4 Then Result(j, 1) = "Insufficient"
        ElseIf (Countarrays(i, 1).value) = 4 Then Result(j, 1) = "Complete"
        Next j
    Next i

End Sub

1 Ответ

1 голос
/ 15 мая 2019

Это должно сработать: 

Option Explicit
Sub Test()

    Dim MyArray, DictDuplicates As New Scripting.Dictionary, i As Long

    With ThisWorkbook.Sheets("Sheet1") 'change if needed
        MyArray = .Range(.Cells(2, 1), .Cells(2, 2).End(xlDown))
        For i = LBound(MyArray) To UBound(MyArray) 'loop to store all the items and how many times do they repeat
            If Not DictDuplicates.Exists(MyArray(i, 2)) Then 'if doesn't exists will store it
                DictDuplicates.Add MyArray(i, 2), 1
            Else 'if it does exists will increment its item value
                DictDuplicates(MyArray(i, 2)) = DictDuplicates(MyArray(i, 2)) + 1
            End If
        Next i

        For i = LBound(MyArray) To UBound(MyArray) 'loop to give back the result
            Select Case DictDuplicates(MyArray(i, 2))
                Case Is > 4
                    MyArray(i, 1) = "Excess"
                Case Is = 4
                    MyArray(i, 1) = "Complete"
                Case Is < 4
                    MyArray(i, 1) = "Insufficient"
            End Select
        Next i
        .Range(.Cells(2, 1), .Cells(2, 2).End(xlDown)) = MyArray
    End With

End Sub

Обратите внимание, что для работы DictDuplicates необходимо проверить библиотеку Microsoft Scripting Runtime.

...