Многомерный массив для хранения и подсчета вхождений уникальных идентификаторов

Question

Справочная информация:

Пытаясь лучше понять динамические многомерные массивы, я пытаюсь построить один для захвата уникальных значений и подсчета вхождений уникальных значений (то, что я долженбыть в состоянии проверить довольно быстро с помощью счетчика).

Читая о попытке повторно сохранить многомерный массив, я прочитал, что вы можете только повторить последние параметры, поэтому я пытался настроить для 2параметры, где первое - это уникальное значение, а второе - это число: arr (2, k).Если мое понимание неверно, то это также довольно важно.

Окончательный вывод массива, который я выбрасываю в столбец 3 (уникальный идентификатор) и столбец 4 (число вхождений).

---

Проблема:

При добавлении значений в массив я не могу собрать все уникальные значения.Мне удалось собрать 3 уникальных значения, когда в данных есть 6, а вхождения каждого из них остаются на 1, например, не повторяются.

---

Вопрос:

Я прошу прощения, что это, по сути, 2 вопроса ...

• 1) мой подход redim preserver arr (от 2,0 до k) соответствует синтаксису?

• 2) есть ли явная проблема с генерацией моего динамического массива, которая объясняет, почему я не получаю все уникальные значения, захваченные?

Я мог быспросите у третьего о том, почему я не могу заставить работать счетчик событий, но я надеюсь, что, если я пойму вышеупомянутую проблему, я надеюсь, что буду бороться через эту часть.

---

Какие данныевыглядит так:

Все данные в столбце A

cat
dog
mouse
cat
mouse
bear
frog
cat
moose
cat
dog

---

Код вопроса:

Option Explicit

Private Sub unique_arr()
    Dim arr As Variant, i As Long, lr As Long, k As Long
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    ReDim arr(2, k)
    For i = 1 To lr
        If Application.IfError(Application.Match(Cells(i, 1).Value, arr, 0), 0) = 0 Then
            ReDim Preserve arr(2, 0 To k)
            arr(1, k) = Cells(i, 1).Value
            arr(2, k) = 1
            k = k + 1
        Else
            arr(2, Application.Match(Cells(i, 1), arr(1), 0)) = arr(2, Application.Match(Cells(i, 1), arr(1), 0)) + 1
        End If
    Next i
    For i = LBound(arr) To UBound(arr)
        Cells(i + 1, 3).Value = arr(1, i)
        Cells(i + 1, 4).Value = arr(2, i)
    Next i
End Sub

Answer 1

Несмотря на то, что в целом вам лучше справиться со словарем, в сравнении If есть несколько ошибок:

If Application.IfError(Application.Match(Cells(i, 1).Value, arr, 0), 0) = 0 Then

В VBA имеется собственный IsError, который возвращает True / False.

If IsError(Application.Match(Cells(i, 1).Value, arr, 0), 0)) Then

Кроме того, arr является двумерным массивом;по сути он имеет как строки, так и столбцы.Соответствие рабочего листа может работать только с одним столбцом или одной строкой.Вам нужно «отрезать» то, что вы хотите с помощью Index.

If Not IsError(Application.Match(Cells(i, 1).Value, application.index(arr, 1, 0), 0), 0)) Then

Наконец, arr определяется как ReDim arr(2, k).Это делает его arr(0 to 2, 0 to k), поэтому в первом ранге есть три элемента ( 0, 1, 2 ), а не 2. На самом деле вы никогда не используете 0 в первом ранге.Должно быть,

k = 1
ReDim arr(1 to 2, 1 to k)

Завершите все это, и вы получите нечто подобное.

Option Explicit

Private Sub unique_arr()
    Dim i As Long, lr As Long, k As Long, arr As Variant, m As Variant

    'assign values to some vars
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    k = 1
    ReDim arr(1 To 2, 1 To k)

    'loop through cells, finding duplicates and counting
    For i = 1 To lr
        m = Application.Match(Cells(i, 1).Value, Application.Index(arr, 1, 0), 0)
        If IsError(m) Then
            ReDim Preserve arr(1 To 2, 1 To k)
            arr(1, k) = Cells(i, 1).Value
            arr(2, k) = 1
            k = k + 1
        Else
            arr(2, m) = arr(2, m) + 1
        End If
    Next i

    'loop through array's second rank
    For i = LBound(arr, 2) To UBound(arr, 2)
        Cells(i, 3).Value = arr(1, i)
        Cells(i, 4).Value = arr(2, i)
    Next i

End Sub

Answer 2

Для чего-то подобного, я бы использовал словарь, например, так:

Sub ExtractUniqueCounts()

    Dim ws As Worksheet
    Dim rCell As Range
    Dim hUnq As Object

    Set ws = ActiveWorkbook.ActiveSheet
    Set hUnq = CreateObject("Scripting.Dictionary") 'Create Dictionary object

    'Loop through populated cells in column A
    For Each rCell In ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp)).Cells
        'Ignore blanks
        If Len(rCell.Value) > 0 Then
            'Check if this is a new, unique value that hasn't been added yet
            If Not hUnq.Exists(rCell.Value) Then
                'New unique value found, add to dictionary and set count to 1
                hUnq(rCell.Value) = 1
            Else
                'Not a unique value, increase existing count
                hUnq(rCell.Value) = hUnq(rCell.Value) + 1
            End If
        End If
    Next rCell

    'Check if there are any results
    If hUnq.Count > 0 Then
        'Results found
        'Output the keys (unique values)
        ws.Range("C1").Resize(hUnq.Count).Value = Application.Transpose(hUnq.keys)

        'Output the values of the keys (the counts in this case)
        ws.Range("D1").Resize(hUnq.Count).Value = Application.Transpose(hUnq.items)
    Else
        'No results, return error
        MsgBox "No data"
    End If

End Sub