12
返回列表 上一主題 發帖

[發問] excel VBA 從大量資料中裡找出共同重複的資料

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
11# 跳轉到 »
發表於 2014-4-17 22:38 | 只看該作者
回復 10# Duck


    計算各自母的出現率不難，但實在不解前3個工作表的字母要求出現率在80%以上
幾乎不可能啊!
假設有，那就是要顯示到工作表4的B欄嗎?
那跟A欄的資料又有甚麼關聯?
上傳的範例最好是能顯示想要的結果，否則很難看出你的需求
學海無涯_不恥下問

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
12#
發表於 2015-12-31 20:10 | 只看該作者
本帖最後由 yen956 於 2015-12-31 20:12 編輯

回復 4# Hsieh
超版你好!!
請問: If Application.CountIf(Rng, a) > 1 Then d(a.Value) = ""
中的 d(a.Value) = "" 是什麼意思?
猜想是將 a 的 Key 丟到字典中, 或是將 a 的 Item 丟到字典中,
但為什麼是 d(a.Value) = "" 呢? 作用是什麼?
謝謝!!

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
13#
發表於 2016-1-1 08:06 | 只看該作者
回復 12# yen956

TOP

hcm19522

帖子
1387 
主題
4 
精華
0 
積分
1397 
點名
0  
作業系統
WIN 
軟體版本
2007 
閱讀權限
50 
性別
男 
註冊時間
2015-9-11 
最後登錄
2024-11-26 

熱烈參與勳章
14#
發表於 2016-1-1 09:39 | 只看該作者
http://blog.xuite.net/hcm19522/twblog/369872449
函數 參考即可

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
15#
發表於 2016-1-1 10:15 | 只看該作者
本帖最後由 GBKEE 於 2016-1-1 10:16 編輯

回復 12# yen956
vba的說明
  1. Dictionary 物件
  2. 物件，用於儲存資料關鍵字和項目對。
  3. 語法
  4. Scripting.Dictionary
  5. 請注意
  6. Dictionary 物件與 PERL 相關陣列全等。可以是任何型式的資料的項目被儲存在陣列中。每個項目都與一個唯一的關鍵字相關。該關鍵字用來取出單個項目，通常是整數或字串，可以是除陣列外的任何型態。
  7. 下面的程式碼舉例說明了如何建立一個 Dictionary 物件：

  9. Dim d                   '建立一個變數
  10. Set d = CreateObject(Scripting.Dictionary)
  11. d.Add "a", "Athens"     '加入一些關鍵字和項目
  12. d.Add "b", "Belgrade"
  13. d.Add "c", "Cairo"
複製代碼
9#附檔的程式碼試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim d As Object, E As Variant, AR(1 To 3), i As Integer
  4.     Dim Rng As Range, AX(), M As Variant
  5.     Set d = CreateObject("SCRIPTING.DICTIONARY")
  6.     '工作表1-> 工作表3  '出現機率為80%的字母*****
  7.     For i = 1 To 3   '"工作表1"->"工作表3" 在活頁簿上的 Index
  8.          MsgBox Sheets(i).Name  '可註解掉
  9.         With Sheets(i).Range("B:B").SpecialCells(xlCellTypeConstants).Offset(, 1)
  10.             .Cells = "=COUNTIF(C2,RC[-1])/COUNTA(C1)"  '儲存格寫上公式
  11.             AR(i) = Application.WorksheetFunction.Transpose(.Offset(, -1).Resize(, 2).Value)
  12.             'AR(i) 導入英文字母出現百分比機率
  13.             For Each E In .Cells
  14.                 If E >= 0.8 Then d(E.Offset(, -1).Value) = ""
  15.             Next
  16.             .Cells = .Value             '公式轉為值
  17.             .NumberFormatLocal = "0%"   '數字格式化
  18.             .Cells.Offset(, 1) = ""
  19.             If d.Count >= 1 Then
  20.                 .Cells(1).Range("B1").Resize(d.Count) = Application.WorksheetFunction.Transpose(d.keys)
  21.             End If
  22.         End With
  23.         d.RemoveAll
  24.     Next
  25.    
  26.     '***工作表4 上B欄位中，每個英文字母出現在指定工作表的比率***
  27.     Set Rng = Sheets("工作表4").Range("A1")
  28.     i = 0
  29.     Do Until Rng Is Nothing
  30.         AX = AR(Sheets(Rng.Value).Index) '"工作表1"->"工作表3" 在活頁簿上的 Index
  31.         'AR(Sheets(Rng.Value).Index) 導出各個工作表上英文字母的機率
  32.         M = Application.Match(Rng.Offset(i, 1), Application.Index(AX, 1), 0)
  33.         'Application.Match 工作表函數
  34.         With Rng.Offset(i, 2) 'C欄
  35.             If Not IsError(M) Then
  36.                 .Cells = AX(2, M)
  37.             Else
  38.                 .Cells = 0
  39.             End If
  40.             .NumberFormatLocal = "0%"
  41.         End With
  42.         i = i + 1
  43.         If Rng.Offset(i) <> "" Then  '下一個工作表
  44.             Set Rng = Rng.Offset(i)
  45.             i = 0
  46.         ElseIf Rng.Offset(i, 1) = "" Then '沒有字串
  47.             Set Rng = Nothing   '離開迴圈的條件
  48.         End If
  49.     Loop
  50. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-26 
16#
發表於 2016-1-1 11:13 | 只看該作者
本帖最後由 准提部林 於 2016-1-1 11:16 編輯

回復 12# yen956


d(a.Value) = ""　＿＿key 為 a.value　，　item 為 空字符

key者，可稱其為〔索引值〕，具〔唯一不重覆〕性，
若只想取出不重覆項目，item 就不須處理，所以給個任意資料，一般給空字符即可！

要注意：１．文字格式與數值格式的純數字，或英文的大．小寫，放在 key 中是視為不同的！
　　　　２．key 的來源若為〔儲存格參照〕，必須使用 rng.value 或 rng.text 或 rng & "" 方式，
　　　　　　這時就涉及〔數值〕與〔文字〕格式的問題，依需求去決定其格式！
　　　　　　例如：Ａ１為〔日期〕2016/01/01，自訂格式為〔YYYY/MM/DD]，亦即其值為〔數值〕42370，只是格式看起來為日期，
　　　　　　　　　那麼，[A1].Value　為 2016/1/1 等同 42370
　　　　　　　　　　　　[A1].Text　　則為〔文字〕2016/01/01
　　　　　　　　　　　　[A1] & ""　　又為〔文字〕2016/1/1

Sub 測試()
Set xD = CreateObject("Scripting.Dictionary")
xD([A1].Value) = ""
xD([A1].Text) = ""
xD([A1] & "") = ""
xD(42370) = ""
MsgBox xD.Count　'只有３而非４個，因第１及第４〔值〕相同
End Sub


＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
至放 item 因各種需求，可做很多的變化，一時說不清，可多找找更多實際範例看看∼∼
　

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
17#
發表於 2016-1-1 13:01 | 只看該作者
感謝c_c_lai, GBKEE, 准提部林 等大大的說明,
因為一般文件只提到 d.Add "a", "Athens" 的方法,
現在總算知道 d(a.Value) = "" 這個方法的真正函義,
d(a.Value) = ""　＿＿key 為 a.value　，　item 為 空字符
謝謝大大們詳細的說明, 謝謝!!

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
18#
發表於 2016-1-4 17:51 | 只看該作者
花了不少時間, 總算對 Ditionary 有一點點了解,
d(a.Value) = ""  與
If Not exists(a.Value) Then d.Add a.Value, "" 同義.
下列修改自 15# GBKEE版大的VBA(版大的執行結果完全正確),
請指教!!
  1. '修改自 15# GBKEE版大的VBA
  2. Sub Test()
  3.     Dim d As Object, d2 As Object, AR(1 To 3), ArC()
  4.     Dim M As Variant, E As Variant
  5.     Dim LstA As Integer, LstB As Integer, Cnt As Integer, Cnt2 As Integer
  6.     Dim i As Integer, J As Integer
  7.     Set d = CreateObject("SCRIPTING.DICTIONARY")
  8.     Set d2 = CreateObject("SCRIPTING.DICTIONARY")
  9.     Range("C:G").ClearContents    '清除工作表4 C欄-->G欄
  10.     Range("E:E").Interior.ColorIndex = xlNone
  11.     LstB = [B65536].End(xlUp).Row
  12.     Cnt = 1
  13.     Cnt2 = 1
  14.     ArC = Array(35, 36, 37, 38)
  15.    
  16.     '以下計算 工作表1-> 工作表3 出現機率為80%的字母*****
  17.     For i = 1 To 3   '從 "工作表1" 到 "工作表3"
  18.         Sheets(i).Range("C:E").ClearContents    '清除每一頁的 C欄-->E欄
  19.         With Sheets(i).[C1].Resize(Sheets(i).[B65536].End(xlUp).Row)   '即[C1:Cxx]
  20.             .Cells = "=COUNTIF(C2,RC[-1])/COUNTA(C1)"
  21.             '[C1]公式 = COUNTIF(B:B,B1)/COUNTA(A:A), 即計算每個字母出現的機率
  22.             
  23.             AR(i) = Application.Transpose(.Offset(, -1).Resize(, 2).Value)
  24.             '將 B欄,C欄 轉置為 AR(1 to 2, 1 to 21)
  25.             
  26.             '將英文字母出現百分比機率導入 AR(i)
  27.             For Each E In .Cells    '歷遍每一頁的 [C1:Cxx]
  28.                 d2.Item(E.Offset(, -1).Value) = E.Value
  29.                 '將字母(Key)及機率(Item)全部存入 字典d2 中(不論機率大小)
  30.                
  31.                 If E >= 0.8 Then d(E.Offset(, -1).Value) = E.Value
  32.                 '將機率 >=80% 的字母及機率, 放到 字典d 中
  33.             Next
  34.             
  35.             .Cells = .Value             '公式轉為值
  36.             
  37.             If d.Count >= 1 Then
  38.                 .Cells(1).Range("B1").Resize(d.Count) = Application.Transpose(d.keys)   '傾倒字母到每頁的 [D1:Dxx]
  39.                 .Cells(1).Range("C1").Resize(d.Count) = Application.Transpose(d.Items)  '傾倒機率到每頁的 [E1:Exx]
  40.                 '★這裡若將 .Range("B1") 改為 .[B1]
  41.                 '  則會出現 "物件不支援屬性或方法" 的錯誤!!
  42.             End If
  43.             
  44.             If d2.Count >= 1 Then
  45.                 '固定式(工作表4的A欄及B欄的表格事先填好)
  46.                 '***工作表4上 B欄位中，每個英文字母出現在指定工作表的比率***
  47.                 M = Application.Match(Sheets(i).Name, [A:A])
  48.                 If IsNumeric(M) Then
  49.                     If i = 3 Then
  50.                         LstA = LstB
  51.                     Else
  52.                         LstA = Cells(M, 1).End(xlDown).Row - 1
  53.                     End If
  54.                     For J = M To LstA
  55.                         If d2.Exists(Cells(J, 2).Value) Then
  56.                             Cells(J, 3) = d2(Cells(J, 2).Value)
  57.                         End If
  58.                     Next
  59.                     Cnt = LstA + 1
  60.                 End If
  61.             
  62.                 '機動式(E欄(工作表名稱)及F欄(字母)的表格由VBA填入)
  63.                 '***工作表4上 F欄位中，每個英文字母出現在指定工作表的比率***
  64.                 Cells(Cnt2, 5) = Sheets(i).Name    '工作表名稱
  65.                 Cells(1).Range("E" & Cnt2).Resize(d2.Count).Interior.ColorIndex = ArC(i)
  66.                 Cells(1).Range("F" & Cnt2).Resize(d2.Count) = Application.Transpose(d2.keys)   '傾倒字母
  67.                 Cells(1).Range("G" & Cnt2).Resize(d2.Count) = Application.Transpose(d2.Items)  '傾倒機率
  68.                 Cnt2 = d2.Count + 1
  69.             End If
  70.         End With
  71.         d.RemoveAll
  72.         d2.RemoveAll
  73.         Sheets(i).Range("C:C", "E:E").NumberFormatLocal = "0%"  '數字格式化
  74.     Next
  75.     Range("C:C", "G:G").NumberFormatLocal = "0%"  '數字格式化
  76. End Sub
複製代碼

TOP

        靜思自在 : 道德是提昇自我的明燈，不該是呵斥別人的鞭子。
12
返回列表 上一主題