帖子: 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

樓主熱帖

loyyee

中學生 Rank: 2

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

論壇榮譽勳章論壇贊助勳章

7^#

發表於 2011-9-12 14:27 | 只看該作者

感謝Hsieh程式可以用了。

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

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

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

6^#

發表於 2011-9-6 14:27 | 只看該作者

回復 5# loyyee

Sub nn()
Set d = CreateObject("Scripting.Dictionary")
For Each a In Range([A1], [A1].End(xlDown))
If IsEmpty(d(a.Value)) Then
d(a.Value) = a.Offset(, 1)
ElseIf IsError(Application.Match(a.Offset(, 1), Split(d(a.Value), ","), 0)) Then
d(a.Value) = d(a.Value) & "," & a.Offset(, 1)
End If
Next
For Each ky In d.keys
d(ky) = Array(ky, UBound(Split(d(ky), ",")) + 1)
If mystr = "" Then
mystr = Join(d(ky), "次數=")
Else
mystr = mystr & Chr(10) & Join(d(ky), "次數=")
End If
Next
mystr = mystr & Chr(10) & "筆數= " & d.Count & "(因出現 : " & Join(d.keys, "、") & Application.Text(d.Count, "[DBNum1]") & "筆資料)"
[C:E] = ""
[C1].Resize(d.Count, 2) = Application.Transpose(Application.Transpose(d.items))
[C1].Offset(d.Count, 3) = mystr
End Sub

複製代碼

學海無涯_不恥下問

TOP

loyyee

中學生 Rank: 2

帖子: 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

超級版主 Rank: 8 Rank: 8

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

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

4^#

發表於 2011-9-4 22:00 | 只看該作者

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

複製代碼

回復 3# loyyee

學海無涯_不恥下問

TOP

loyyee

中學生 Rank: 2

帖子: 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

dechiuan999

中學生 Rank: 2

帖子: 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