用于存储和计算唯一 ID 出现次数的多维数组

Question

背景：

为了更好地理解动态多维数组，我试图构建一个来捕获唯一值并计算唯一值的出现次数（我应该能够使用 countif 快速验证这一点）。

在阅读有关尝试 redim 保留多维数组的信息时，我读到您只能对最后一个参数进行 redim，因此我尝试设置 2 个参数，其中第一个是唯一值，第二个是计数：arr(2,k)。如果我的理解是错误的，那也很重要。

我放入第 3 列（唯一 ID）和第 4 列（出现次数）的数组的最终输出。

---

问题：

向数组添加值时，我无法收集所有唯一值。当数据中有 6 个时，我已经能够收集 3 个唯一值，并且每个值的出现都保持在 1，例如，不迭代。

---

问题：

抱歉，这基本上是 2 个问题...

• 1) 我使用 redim preserver arr(2,0 to 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