返回列表 上一主題 發帖

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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 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

        靜思自在 : 有智慧才能分辨善惡邪正；有謙虛才能建立美滿人生。
返回列表 上一主題