計算不重複資料出現次數 [已解決]

loyyee

請問要如何用巨集計算下列不重複資料出現次數?
         A             B
1  0001        A1
2  0001        A2
3  0001        A2
4  0001        A3
5  0002        A1
6  0002        B1
7  0002        B1
8  0002        B1

得到結果：0001出現不重複次數=3、0002出現不重複次數=2

dechiuan999

你好：
  請問你的計算基礎為何呢？
如果以0002出現不重覆次數為=2時，
想必是以A及B合併為KEY值，
0002A1 一次
0002B1 三次，不重覆次數為二
那0001應為1次才合理。
0001如何計算不重覆次數為=3呢？
如果上述推理正確時，請試試下列語法
Sub aa()
   
    '請先由工具列引用Microsoft Scripting Rungtime
   
    Dim mDic As Scripting.Dictionary
    Dim mSht As Worksheet
    Dim mRng As Range, mRng1 As Range
    Dim E As Range
    Dim mTmp, mVal
    Dim i%
   
    Set mDic = CreateObject("scripting.dictionary")
    Set mSht = Worksheets(1)
    With mSht
        Set mRng = .Range("a1", Range("a" & .Rows.Count).End(xlUp))
            For Each E In mRng
                If Not E.Value = Empty Then
                    If Not mDic.Exists(E.Value & "_" & E.Offset(, 1).Value) Then
                        mDic(E.Value & "_" & E.Offset(, 1).Value) = 1
                        
                    Else
                        mDic(E.Value & "_" & E.Offset(, 1).Value) = mDic(E.Value & "_" & E.Offset(, 1).Value) + 1
                    End If
                    
                End If
            Next
            
            For Each E In mRng
                E.Offset(, 3).Value = E.Value & "_" & E.Offset(, 1).Value
            Next
            
            mKey = mDic.Keys
         
            For i = LBound(mKey) To UBound(mKey)
               mVal = mDic(mKey(i))
               If mVal > 1 Then
                  Set mRng1 = mSht.Columns(4).Find(what:=mKey(i), lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext)
                  If Not mRng1 Is Nothing Then
                    mRng1.Offset(, -1).Value = mVal - 1
                  End If
                End If
            Next
            .Columns(4).ClearContents            
    End With            
End Sub

loyyee

回復 2# dechiuan999


    您好，抱歉沒說清楚，A.B欄位是要合併起來看才對。
0001 出現:A1.A2.A3=3次

Hsieh

1. Sub nn()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For Each a In Range([A1], [A1].End(xlDown))
   
4.   If IsEmpty(d(a.Value)) Then
   
5.      d(a.Value) = a.Offset(, 1)
   
6.   ElseIf IsError(Application.Match(a.Offset(, 1), Split(d(a.Value), ","), 0)) Then
   
7.      d(a.Value) = d(a.Value) & "," & a.Offset(, 1)
   
8.   End If
   
9. Next
   
10. For Each ky In d.keys
    
11.   d(ky) = Array(ky, UBound(Split(d(ky), ",")) + 1)
    
12. Next
    
13. [C1].Resize(d.Count, 2) = Application.Transpose(Application.Transpose(d.items))
    
14. End Sub

複製代碼

回復 3# loyyee

loyyee

回復 4# Hsieh

感謝Hsieh程式可以用了。
再請問一下如何在 F3儲存格加入註解顯示計算出來的結果：

註解內容如下~

0001 次數=3
0002 次數=2
筆數：2 (因出現：0001、0002二筆資料)

Hsieh

回復 5# loyyee

1. Sub nn()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For Each a In Range([A1], [A1].End(xlDown))
   
4.   If IsEmpty(d(a.Value)) Then
   
5.      d(a.Value) = a.Offset(, 1)
   
6.   ElseIf IsError(Application.Match(a.Offset(, 1), Split(d(a.Value), ","), 0)) Then
   
7.      d(a.Value) = d(a.Value) & "," & a.Offset(, 1)
   
8.   End If
   
9. Next
   
10. For Each ky In d.keys
    
11.   d(ky) = Array(ky, UBound(Split(d(ky), ",")) + 1)
    
12. If mystr = "" Then
    
13.   mystr = Join(d(ky), "次數=")
    
14.   Else
    
15.   mystr = mystr & Chr(10) & Join(d(ky), "次數=")
    
16. End If
    
17. Next
    
18. mystr = mystr & Chr(10) & "筆數= " & d.Count & "(因出現 : " & Join(d.keys, "、") & Application.Text(d.Count, "[DBNum1]") & "筆資料)"
    
19. [C:E] = ""
    
20. [C1].Resize(d.Count, 2) = Application.Transpose(Application.Transpose(d.items))
    
21. [C1].Offset(d.Count, 3) = mystr
    
22. End Sub

複製代碼

loyyee

感謝Hsieh程式可以用了。