多维数组用于存储和计数唯一IDs的出现次数。
多维数组用于存储和计数唯一IDs的出现次数。
提问于 2019-03-07 19:28:14
背景：
在试图更好地理解动态多维数组的过程中，我试图构建一个数组来捕获唯一的值并计数唯一值的出现情况(这是我应该能够很快用countif验证的)。
在阅读有关尝试redim保留多维数组的内容时，我读到您只能使用redim的最后一个参数，因此我试图设置两个参数，其中第一个参数是唯一值，第二个参数是计数: arr(2，k)。如果我的理解是错误的，那么这也是相当重要的。
我要抛入第3列(唯一ID)和第4列(事件#)的数组的最后输出。
发行：
当向数组添加值时，我无法收集所有唯一的值。当数据中有6个时，我已经收集了3个唯一的值，并且每个值的出现都停留在1，例如，不迭代。
问题：
我很抱歉这基本上是两个问题..。
- 1)我使用redim保存器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回答 2
Stack Overflow用户
回答已采纳
发布于 2019-03-07 19:54:49
虽然总体上使用字典会更好，但是If比较有一些错误。
If Application.IfError(Application.Match(Cells(i, 1).Value, arr, 0), 0) = 0 ThenVBA有自己的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 to 2, 0 to k)，所以在第一列中有三个元素(0，1，2)，而不是2。应该是，
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 SubStack Overflow用户
发布于 2019-03-07 20:38:56
对于这样的事情，我会用字典，像这样：
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页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/55051441
复制相关文章
相似问题
腾讯云开发者
