返回列表 上一主題 發帖

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

loyyee

帖子
42 
主題
9 
精華
0 
積分
64 
點名
0  
作業系統
WINDOW7 
軟體版本
OFFICE2003 
閱讀權限
20 
性別
男 
註冊時間
2011-9-3 
最後登錄
2013-6-10 

論壇榮譽勳章論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2011-9-4 17:52 | 只看該作者

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

本帖最後由 loyyee 於 2011-9-17 00:06 編輯

請問要如何用巨集計算下列不重複資料出現次數?
         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

帖子
231 
主題
55 
精華
0 
積分
293 
點名
0  
作業系統
winxp 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
KEELUNG 
註冊時間
2010-7-24 
最後登錄
2018-8-28 
2#
發表於 2011-9-4 19:34 | 只看該作者
本帖最後由 dechiuan999 於 2011-9-4 19:41 編輯

你好：
  請問你的計算基礎為何呢？
如果以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

TOP

loyyee

帖子
42 
主題
9 
精華
0 
積分
64 
點名
0  
作業系統
WINDOW7 
軟體版本
OFFICE2003 
閱讀權限
20 
性別
男 
註冊時間
2011-9-3 
最後登錄
2013-6-10 

論壇榮譽勳章論壇贊助勳章
3#
發表於 2011-9-4 21:42 | 只看該作者
回復 2# dechiuan999


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

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
255  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-25 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
4#
發表於 2011-9-4 22:00 | 只看該作者
  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
學海無涯_不恥下問

TOP

loyyee

帖子
42 
主題
9 
精華
0 
積分
64 
點名
0  
作業系統
WINDOW7 
軟體版本
OFFICE2003 
閱讀權限
20 
性別
男 
註冊時間
2011-9-3 
最後登錄
2013-6-10 

論壇榮譽勳章論壇贊助勳章
5#
發表於 2011-9-6 11:14 | 只看該作者
回復 4# Hsieh

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

註解內容如下~

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

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
255  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-25 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
6#
發表於 2011-9-6 14:27 | 只看該作者
回復 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
複製代碼
學海無涯_不恥下問

TOP

loyyee

帖子
42 
主題
9 
精華
0 
積分
64 
點名
0  
作業系統
WINDOW7 
軟體版本
OFFICE2003 
閱讀權限
20 
性別
男 
註冊時間
2011-9-3 
最後登錄
2013-6-10 

論壇榮譽勳章論壇贊助勳章
7#
發表於 2011-9-12 14:27 | 只看該作者
感謝Hsieh程式可以用了。

TOP

        靜思自在 : 屋寬不如心寬。
返回列表 上一主題