Excel 返回按列A索引的列B中唯一结果的计数
我更喜欢使用VBA来实现这一点,根据需要执行,而不是使用公式,因为我有16000行 电子表格中的条目在a栏中列出了几百次。我需要看看有多少条目在B栏中有不同的值Excel 返回按列A索引的列B中唯一结果的计数,excel,vba,Excel,Vba,我更喜欢使用VBA来实现这一点,根据需要执行,而不是使用公式,因为我有16000行 电子表格中的条目在a栏中列出了几百次。我需要看看有多少条目在B栏中有不同的值 COL A COL B A 1 A 2 A 1 A 1 A 2 A 1 A 1 A 1 B 1 B 1 B 1 B 1 B 1 现在返回列B中唯一结果的计数,按列A索引 COL
COL A COL B
A 1
A 2
A 1
A 1
A 2
A 1
A 1
A 1
B 1
B 1
B 1
B 1
B 1
现在返回列B中唯一结果的计数,按列A索引
COL A COL B
A 2
B 1
我从这个开始,然后我的头开始旋转(我真的很讨厌VBA,它根本不适合我):
编辑-删除我开始使用的垃圾,因为它对任何人都没有帮助。这就是我最终使用的方法,我不得不修改@alter answer,只显示大于1的索引,然后将其输出到文本文件而不是msgbox(第一次运行它时,我有数百个msgbox)
Sub CountUnique()
On Error GoTo ErrorHandler:
Dim keyMap As Object, values As Object
Dim key As String, value As String
Dim keysColumn As String, valuesColumn As String
Dim row As Long
Dim rowCount As Long
Dim item As Object
Dim outFile As String
myFile = "C:\usercount.txt"
Set keyMap = CreateObject("Scripting.Dictionary")
rowCount = ActiveSheet.UsedRange.Rows.Count
keysColumn = "C"
valuesColumn = "E"
For row = 2 To rowCount
key = Range(keysColumn & row).Text
value = Range(valuesColumn & row).Text
If keyMap.Exists(key) Then
Set values = keyMap.item(key)
If values.Exists(value) = False Then values.Add value, ""
Else
Set values = CreateObject("Scripting.Dictionary")
values.Add value, ""
keyMap.Add key, values
End If
Next row
Open myFile For Output As #1
For Each v In keyMap.keys
key = v
Set values = keyMap.item(key)
If values.Count > 1 Then
Write #1, key & ": " & values.Count
End If
Next v
Close #1
Exit Sub
ErrorHandler:
MsgBox "Something went wrong"
End Sub
快速解决方案,只需使用2D字典。第一个维度是a列(索引所依据的列),第二个维度是B列(值)。字典的好处是它有一个“存在”函数,可以检查键是否已在使用
Sub CountUnique()
On Error GoTo ErrorHandler:
Dim keyMap As Object, values As Object
Dim key As String, value As String
Dim keysColumn As String, valuesColumn As String
Dim row As Long
Dim rowCount As Long
Dim item As Object
Set keyMap = CreateObject("Scripting.Dictionary")
rowCount = ActiveSheet.UsedRange.Rows.Count
keysColumn = "A"
valuesColumn = "B"
For row = 2 To rowCount
key = Range(keysColumn & row).Text
value = Range(valuesColumn & row).Text
If keyMap.Exists(key) Then
Set values = keyMap.item(key)
If values.Exists(value) = False Then values.Add value, ""
Else
Set values = CreateObject("Scripting.Dictionary")
values.Add value, ""
keyMap.Add key, values
End If
Next row
For Each v In keyMap.keys
key = v
Set values = keyMap.item(key)
MsgBox key & ": " & values.Count
Next v
Exit Sub
ErrorHandler:
MsgBox "Something went wrong"
End Sub
另一种方法:
Sub Tester()
CountUnique Range("A2:A10"), Range("d2")
End Sub
Sub CountUnique(rngIn As Range, rngOut As Range)
Dim d As Object
Dim c As Range, tmp, v, arr(), i As Long, ex, k
Set d = CreateObject("scripting.dictionary")
For Each c In rngIn.Cells
tmp = Trim(c.Value)
v = Trim(c.Offset(0, 1).Value)
If d.exists(tmp) Then
arr = d(tmp)
ex = False
For i = LBound(arr) To UBound(arr)
If v = arr(i) Then
ex = True
Exit For
End If
Next i
If Not ex Then
ReDim Preserve arr(LBound(arr) To UBound(arr) + 1)
arr(UBound(arr)) = v
d(tmp) = arr
End If
Else
ReDim arr(0 To 0)
arr(0) = v
d(tmp) = arr
End If
Next c
i = 0
For Each k In d.keys
rngOut.Offset(i, 0).Value = k
arr = d(k)
rngOut.Offset(i, 1).Value = Join(arr, ",")
rngOut.Offset(i, 2).Value = 1 + (UBound(arr) - LBound(arr))
i = i + 1
Next k
End Sub
你应该考虑使用一个数据透视表。这将返回你正在寻找的最终结果。只需选择整个范围,创建一个数据透视表,并将两列都放进“行标签”区域。
这消除了大量费心的VBA脚本编写的需要。我不在乎结果如何返回,只要我可以复制和粘贴它们,所以除了消息框以外的任何东西都很好。这不是一个你可以发布需求和期望答案的地方,而不需要至少描述你尝试了什么……你应该能够做到这是一个scripting.dictionary对象-尝试一下,如果遇到问题,请用代码发回。@TimWilliams我已经尝试了大约3个小时了,我的所有努力实际上都是徒劳的,我不想混淆我要做的事情。@pnuts我愿意接受一个公式。我只是厌倦了,因为我有工作手册因为VLOOKUPS,只有几百行几乎无法使用。谢谢,这是我心中的概念,我就是受不了VB,它对我来说是完全陌生的。我相信这是一个很好的答案。但我尝试做的事情对我来说太简单了,我可以用一个shell脚本来完成。。。(天哪,为什么我不直接用一个shell脚本来做呢?我几个小时前就已经完成了,它是一个CSV)只用了几行。我讨厌VB。我不明白有必要使用晦涩的内置函数(对我来说是晦涩的)来做些什么。谢谢你的回答。有几十种方法可以剥那只猫的皮,但你确实问了;-).只要对你有用就用吧。。。