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

背景：

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

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

在阅读有关尝试重拨保留多维数组的内容时，我了解到您只能重拨最后一个参数，因此我尝试设置两个参数，其中第一个是唯一值，第二个是计数：arr（2，k）。如果我的理解是错误的，那么这也是非常重要的

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

---

问题：

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

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

---

问题：

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

很抱歉，这基本上是两个问题

• 1） 我使用的redim保存器arr（2,0到k）语法是否合适

• 2） 我的动态数组生成是否有一个突出的问题，可以解释为什么我没有捕获所有的唯一值

我可以问第三个问题，为什么我不能让事件计数工作，但我希望，如果我了解上述问题，我有希望通过这一部分的斗争

---

数据的外观：

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

所有数据都在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

---

虽然使用字典总体上会更好，但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是一个二维阵列；本质上，它既有行也有列。工作表的匹配只能在一列或一行上使用。你需要用索引“切掉”你想要的东西

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

最后，arr被定义为

ReDim-arr（2，k）

。这使得它

arr（0到2，0到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

---

对于这样的事情，我会使用字典，比如：

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

---

…事后来看，我可以对上述数据使用Match（）并仅在找到它时添加，例如application.Match（单元格（I，1）.value，range（单元格（1,1），单元格（I-1,1）），0）。。。但是需要从第2行开始以避免错误。这必须是VBA吗？pivot表可以快速轻松地完成此操作。@tigeravatar这纯粹是为了帮助理解如何通过（相对）简单的过程引用/使用多维数组。我知道有更简单的方法来执行这项特定任务，但可以说，我觉得这是一种能让我获得最大回报的方法。这是一种很好的方法，并解释了如何按照OP的要求使用阵列、+1新贡献者和提供良好书面说明？！你真是独角兽（不要和尤尼奇·霍恩混淆）。我很欣赏关于在第一维度中不使用0的解释；这是使这项工作发挥作用的关键。另外，我很抱歉对application.iferror（）懒惰。。。我发现自己经常忽略if语句的boolean用法感谢字典的使用。我很感谢大家对这一点的评论，因为我知道dictionary也可以执行这一特定任务。我非常努力地理解设置和动态增加多维数组的适当用法，并试图将我的理解向前推进。我要说的是，我从中得到的最大收获是使用转置输出数据。这是一个巨大的节省时间！关于字典的另一课。现在我将数组视为一个工作表，但字典只是前两行（因此转置），尽管对于唯一值来说，速度非常快。