如何用字典，统计重复数？

ning84

1. Sub CountWordsWithDictionary()
   
2.     Dim dict As Dictionary
   
3.     Set dict = New Dictionary
   
4.     Dim text As String
   
5.     Dim words() As String
   
6.     Dim word As Variant
   
7.    
   
8.     ' 这里的文本可以替换为你想要分析的文本
   
9.     text = "AA BB  BB CC AA CC AA CC AA AA"
   
10.     ' 将文本转换为小写并用空格分割
    
11.     text = LCase(text)
    
12.     words = Split(text, " ")
    
13.    
    
14.     ' 遍历所有单词并统计次数
    
15.     For Each word In words
    
16.         If word <> "" Then
    
17.             If dict.Exists(word) Then
    
18.                 dict(word) = dict(word) + 1
    
19.             Else
    
20.                 dict.Add word, 1
    
21.             End If
    
22.         End If
    
23.     Next word
    
24.    
    
25.     ' 打印结果
    
26.     Dim key As Variant
    
27.     For Each key In dict.Keys
    
28.         Debug.Print key & " -- 重复数是 -- " & dict(key)
    
29.     Next key
    
30. End Sub
    

复制代码

重复数的关键语句是
Dict(word) = Dict(word) + 1

结果

aa -- 重复数是 -- 5
bb -- 重复数是 -- 2
cc -- 重复数是 -- 3

************************************************************

以这个代码为基础，编制代码

1. Sub DD()
   
2.    Dim Str
   
3.    Dim Rng As Range
   
4.        Set Rng = Selection
   
5.    Dim Sht As Worksheet
   
6.        Set Sht = Rng.Parent
   
7.        With Sht
   
8.            Set Rng = .Range(.Cells(1, 1).Formula)
   
9.            Debug.Print Rng.Address
   
10.        End With
    
11.    Dim Dict As Dictionary
    
12.        Set Dict = New Dictionary
    
13.        For ii = 1 To Rng.Rows.Count
    
14.             Str = Rng(ii, 1)
    
15.             If Dict.Exists(Str) Then
    
16.                Dict(Str) = Dict(Str) + 1
    
17.             Else
    
18.                Dict(Str) = 1
    
19.             End If
    
20.        Next ii
    
21.        Debug.Print Dict.Count, Rng.Rows.Count
    
22.        ''
    
23.        With WorksheetFunction
    
24.             Sht.Cells(4, "D").Resize(Dict.Count, 1) = .Transpose(Dict.Keys())
    
25.             Sht.Cells(4, "E").Resize(Dict.Count, 1) = .Transpose(Dict.Items())
    
26.        End With
    
27.       
    
28. End Sub
    

复制代码

目标要求

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A4].CurrentRegion.Value
    For i = 1 To UBound(ar)
        If Not dic.Exists(ar(i, 1)) Then
            dic(ar(i, 1)) = Array(ar(i, 1), 1, "找出关联的数据", ar(i, 2))
        Else
            br = dic(ar(i, 1))
            br(1) = br(1) + 1
            br(3) = br(3) & "," & ar(i, 2)
            dic(ar(i, 1)) = br
        End If
    Next i
     
    [D11].Resize(dic.Count, 4) = Application.Rept(dic.Items, 1)
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。。

Qs18

Sub qs() '2024/7/3
    Dim arr, i
    arr = Sheet1.Range([a4], Sheet1.Cells(Rows.Count, 2).End(3))
    ReDim brr(1 To UBound(arr), 1 To 4)
    Set dic = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        s = arr(i, 1)
        If Not dic.Exists(s) Then
            m = m + 1
            dic(s) = m
            brr(m, 1) = s: brr(m, 2) = 1: brr(m, 3) = "找出关联的数据": brr(m, 4) = arr(i, 2)
        Else
            r = dic(s)
            brr(r, 2) = brr(r, 2) + 1: brr(r, 4) = brr(r, 4) & "," & arr(i, 2)
            
        End If
    Next
    Sheet1.Range("d10").Resize(m, 4) = brr
End Sub

Qs18

试试..........

Qs18

试试.............

ning84

Qs18 发表于 2024-7-3 19:39
Sub qs() '2024/7/3
    Dim arr, i
    arr = Sheet1.Range([a4], Sheet1.Cells(Rows.Count, 2).End(3)) ...

谢谢你的帮助，学习小结如下

1. 
   
2. Sub qs() '2024/7/3
   
3.     Dim arr, i
   
4.     arr = Sheet1.Range([a4], Sheet1.Cells(Rows.Count, 2).End(3))
   
5.     ReDim brr(1 To UBound(arr), 1 To 4)
   
6.   Dim Dic As Dictionary
   
7.     Set Dic = New Dictionary
   
8.     For i = 1 To UBound(arr)
   
9.         s = arr(i, 1)
   
10.         
    
11.         If Not Dic.Exists(s) Then
    
12.             m = m + 1
    
13.             
    
14.             Dic(s) = m
    
15.             With Dic
    
16.                Debug.Print "Not Dic.Exists(" & s & ")", .Keys(m - 1), .Items(m - 1)
    
17.             End With
    
18.             brr(m, 1) = s: brr(m, 2) = 1: brr(m, 3) = "找出关联的数据": brr(m, 4) = arr(i, 2)
    
19.         Else
    
20.             r = Dic(s)
    
21.             brr(r, 2) = brr(r, 2) + 1: brr(r, 4) = brr(r, 4) & "," & arr(i, 2)
    
22.             Debug.Print , "Dic.Exists(" & s & ")", r, arr(i, 1), arr(i, 2)
    
23.             'Stop
    
24.         End If
    
25.     Next
    
26.     Sheet1.Range("d10").Resize(m, 4) = brr
    
27. End Sub

复制代码

运行结果




Not Dic.Exists(aa)          aa             1
Not Dic.Exists(bb)          bb             2
Not Dic.Exists(cc)          cc             3
              Dic.Exists(aa)               1            aa            KK4
              Dic.Exists(bb)               2            bb            KK5
              Dic.Exists(cc)               3            cc            KK6
              Dic.Exists(aa)               1            aa            KK7
              Dic.Exists(bb)               2            bb            KK8
              Dic.Exists(aa)               1            aa            KK9
              Dic.Exists(bb)               2            bb            KK10
              Dic.Exists(cc)               3            cc            KK11
              Dic.Exists(aa)               1            aa            KK12
Not Dic.Exists(d)           d              4
Not Dic.Exists(d1)          d1             5
              Dic.Exists(bb)               2            bb            KK15
              Dic.Exists(cc)               3            cc            KK16
              Dic.Exists(aa)               1            aa            KK17
              Dic.Exists(d)  4            d             KK18
Not Dic.Exists(d2)          d2             6
              Dic.Exists(bb)               2            bb            KK20
              Dic.Exists(cc)               3            cc            KK21
              Dic.Exists(aa)               1            aa            KK22
              Dic.Exists(d)  4            d             KK23
Not Dic.Exists(d3)          d3             7
              Dic.Exists(bb)               2            bb            KK25
              Dic.Exists(cc)               3            cc            KK26
              Dic.Exists(aa)               1            aa          Not Dic.Exists(aa)            aa             1
Not Dic.Exists(bb)          bb             2
Not Dic.Exists(cc)          cc             3
              Dic.Exists(aa)               1            aa            KK4
              Dic.Exists(bb)               2            bb            KK5
              Dic.Exists(cc)               3            cc            KK6
              Dic.Exists(aa)               1            aa            KK7
              Dic.Exists(bb)               2            bb            KK8
              Dic.Exists(aa)               1            aa            KK9
              Dic.Exists(bb)               2            bb            KK10
              Dic.Exists(cc)               3            cc            KK11
              Dic.Exists(aa)               1            aa            KK12
Not Dic.Exists(d)           d              4
Not Dic.Exists(d1)          d1             5
              Dic.Exists(bb)               2            bb            KK15
              Dic.Exists(cc)               3            cc            KK16
              Dic.Exists(aa)               1            aa            KK17
              Dic.Exists(d)  4            d             KK18
Not Dic.Exists(d2)          d2             6
              Dic.Exists(bb)               2            bb            KK20
              Dic.Exists(cc)               3            cc            KK21
              Dic.Exists(aa)               1            aa            KK22
              Dic.Exists(d)  4            d             KK23
Not Dic.Exists(d3)          d3             7
              Dic.Exists(bb)               2            bb            KK25
              Dic.Exists(cc)               3            cc            KK26
              Dic.Exists(aa)               1            aa            KK27
              Dic.Exists(d)  4            d             KK28
Not Dic.Exists(d4)          d4             8
              Dic.Exists(bb)               2            bb            KK30
              Dic.Exists(cc)               3            cc            KK31
              Dic.Exists(d3)               7            d3            KK32
Not Dic.Exists(paf)         paf            9
              Dic.Exists(paf)              9            paf           KK34
              Dic.Exists(paf)              9            paf           KK35
  KK27
              Dic.Exists(d)  4            d             KK28
Not Dic.Exists(d4)          d4             8
              Dic.Exists(bb)               2            bb            KK30
              Dic.Exists(cc)               3            cc            KK31
              Dic.Exists(d3)               7            d3            KK32
Not Dic.Exists(paf)         paf            9
              Dic.Exists(paf)              9            paf           KK34
              Dic.Exists(paf)              9            paf           KK35

ning84

gwjkkkkk 发表于 2024-7-3 18:54
Option Explicit
Sub TEST6()
    Dim ar, br, i&, dic As Object

谢谢帮助，必须好好深入学习小结。



不明白 Application.Rept(Dict.Items, 1)




这段语句比较好理解。

            With Dict
               Arr = .Items(Rr)
               Debug.Print "Not Dict.Exists(" & ar(i, 1) & ")", Dict.Keys(Rr),
               For jj = 0 To UBound(Arr)
                   Debug.Print Arr(jj),
               Next jj
               Debug.Print Rr
               'Debug.Print
            End With

ning84

gwjkkkkk 发表于 2024-7-3 18:54
Option Explicit
Sub TEST6()
    Dim ar, br, i&, dic As Object

慢慢消化理解代码的奥妙之处。

1. Sub TEST6()
   
2.     Dim ii, jj
   
3.     Dim ar, br, i&, Dict As Dictionary
   
4.     Dim Arr
   
5.     Dim Rr
   
6.     Application.ScreenUpdating = False
   
7.     Set Dict = New Dictionary
   
8.    
   
9.     ar = [A4].CurrentRegion.Value
   
10.     For i = 1 To UBound(ar)
    
11.         If Not Dict.Exists(ar(i, 1)) Then
    
12.             
    
13.             Dict(ar(i, 1)) = Array(ar(i, 1), 1, "找出关联的数据", ar(i, 2))
    
14.             Rr = Dict.Count - 1
    
15.             With Dict
    
16.                Arr = .Items(Rr)
    
17.                Debug.Print "Not Dict.Exists(" & ar(i, 1) & ")", Dict.Keys(Rr),
    
18.                For jj = 0 To UBound(Arr)
    
19.                    Debug.Print Arr(jj),
    
20.                Next jj
    
21.                Debug.Print Rr
    
22.                'Debug.Print
    
23.             End With
    
24.         Else
    
25.             br = Dict(ar(i, 1))
    
26.             br(1) = br(1) + 1
    
27.             br(3) = br(3) & "," & ar(i, 2)
    
28.             Dict(ar(i, 1)) = br
    
29.             Debug.Print , "Dict.Exists(" & ar(i, 1) & ")", Rr, Dict.Count - 1, br(1) + 1, br(3), ar(i, 2)
    
30.             'Stop
    
31.         End If
    
32.     Next i
    
33.      
    
34.     [D11].Resize(Dict.Count, 4) = Application.Rept(Dict.Items, 1)
    
35.    
    
36.     Set Dict = Nothing
    
37.     Application.ScreenUpdating = True
    
38.     Beep
    
39. End Sub
    

复制代码

Not Dict.Exists(aa)         aa            aa             1            找出关联的数据              KK1            0
Not Dict.Exists(bb)         bb            bb             1            找出关联的数据              KK2            1
Not Dict.Exists(cc)         cc            cc             1            找出关联的数据              KK3            2
              Dict.Exists(aa)              2             2             3            KK1,KK4       KK4
              Dict.Exists(bb)              2             2             3            KK2,KK5       KK5
              Dict.Exists(cc)              2             2             3            KK3,KK6       KK6
              Dict.Exists(aa)              2             2             4            KK1,KK4,KK7   KK7
              Dict.Exists(bb)              2             2             4            KK2,KK5,KK8   KK8
              Dict.Exists(aa)              2             2             5            KK1,KK4,KK7,KK9             KK9
              Dict.Exists(bb)              2             2             5            KK2,KK5,KK8,KK10            KK10
              Dict.Exists(cc)              2             2             4            KK3,KK6,KK11  KK11
              Dict.Exists(aa)              2             2             6            KK1,KK4,KK7,KK9,KK12        KK12
Not Dict.Exists(d1)         d1            d1             1            找出关联的数据              KK13           3
Not Dict.Exists(d2)         d2            d2             1            找出关联的数据              KK14           4
Not Dict.Exists(d3)         d3            d3             1            找出关联的数据              KK15           5
Not Dict.Exists(d4)         d4            d4             1            找出关联的数据              KK16           6
Not Dict.Exists(d5)         d5            d5             1            找出关联的数据              KK17           7
              Dict.Exists(d1)              7             7             3            KK13,KK18     KK18
              Dict.Exists(d2)              7             7             3            KK14,KK19     KK19
              Dict.Exists(d3)              7             7             3            KK15,KK20     KK20
              Dict.Exists(aa)              7             7             7            KK1,KK4,KK7,KK9,KK12,KK21   KK21
              Dict.Exists(bb)              7             7             6            KK2,KK5,KK8,KK10,KK22       KK22
              Dict.Exists(cc)              7             7             5            KK3,KK6,KK11,KK23           KK23
              Dict.Exists(aa)              7             7             8            KK1,KK4,KK7,KK9,KK12,KK21,KK24            KK24
              Dict.Exists(d1)              7             7             4            KK13,KK18,KK25              KK25
              Dict.Exists(d2)              7             7             4            KK14,KK19,KK26              KK26
Not Dict.Exists(pp)         pp            pp             1            找出关联的数据              KK27           8
              Dict.Exists(pp)              8             8             3            KK27,KK28     KK28
              Dict.Exists(pp)              8             8             4            KK27,KK28,KK29              KK29

Qs18