麻辣家族討論版版 - Powered by Discuz! Board

Sub ex()
Dim Rng As Range
Set d = CreateObject("Scripting.Dictionary")
Set Rng = Range([B1], [B1].End(xlDown))
For Each a In Rng
If Application.CountIf(Rng, a) > 1 Then d(a.Value) = ""
Next
If d.Count > 1 Then [D2].Resize(d.Count, 1) = Application.Transpose(d.keys)
End Sub

複製代碼

Dictionary 物件
物件，用於儲存資料關鍵字和項目對。
語法
Scripting.Dictionary
請注意
Dictionary 物件與 PERL 相關陣列全等。可以是任何型式的資料的項目被儲存在陣列中。每個項目都與一個唯一的關鍵字相關。該關鍵字用來取出單個項目，通常是整數或字串，可以是除陣列外的任何型態。
下面的程式碼舉例說明了如何建立一個 Dictionary 物件：
Dim d '建立一個變數
Set d = CreateObject(Scripting.Dictionary)
d.Add "a", "Athens" '加入一些關鍵字和項目
d.Add "b", "Belgrade"
d.Add "c", "Cairo"

複製代碼

Option Explicit
Sub Ex()
Dim d As Object, E As Variant, AR(1 To 3), i As Integer
Dim Rng As Range, AX(), M As Variant
Set d = CreateObject("SCRIPTING.DICTIONARY")
'工作表1-> 工作表3 '出現機率為80%的字母*****
For i = 1 To 3 '"工作表1"->"工作表3" 在活頁簿上的 Index
MsgBox Sheets(i).Name '可註解掉
With Sheets(i).Range("B:B").SpecialCells(xlCellTypeConstants).Offset(, 1)
.Cells = "=COUNTIF(C2,RC[-1])/COUNTA(C1)" '儲存格寫上公式
AR(i) = Application.WorksheetFunction.Transpose(.Offset(, -1).Resize(, 2).Value)
'AR(i) 導入英文字母出現百分比機率
For Each E In .Cells
If E >= 0.8 Then d(E.Offset(, -1).Value) = ""
Next
.Cells = .Value '公式轉為值
.NumberFormatLocal = "0%" '數字格式化
.Cells.Offset(, 1) = ""
If d.Count >= 1 Then
.Cells(1).Range("B1").Resize(d.Count) = Application.WorksheetFunction.Transpose(d.keys)
End If
End With
d.RemoveAll
Next
'***工作表4 上B欄位中，每個英文字母出現在指定工作表的比率***
Set Rng = Sheets("工作表4").Range("A1")
i = 0
Do Until Rng Is Nothing
AX = AR(Sheets(Rng.Value).Index) '"工作表1"->"工作表3" 在活頁簿上的 Index
'AR(Sheets(Rng.Value).Index) 導出各個工作表上英文字母的機率
M = Application.Match(Rng.Offset(i, 1), Application.Index(AX, 1), 0)
'Application.Match 工作表函數
With Rng.Offset(i, 2) 'C欄
If Not IsError(M) Then
.Cells = AX(2, M)
Else
.Cells = 0
End If
.NumberFormatLocal = "0%"
End With
i = i + 1
If Rng.Offset(i) <> "" Then '下一個工作表
Set Rng = Rng.Offset(i)
i = 0
ElseIf Rng.Offset(i, 1) = "" Then '沒有字串
Set Rng = Nothing '離開迴圈的條件
End If
Loop
End Sub

複製代碼

'修改自 15# GBKEE版大的VBA
Sub Test()
Dim d As Object, d2 As Object, AR(1 To 3), ArC()
Dim M As Variant, E As Variant
Dim LstA As Integer, LstB As Integer, Cnt As Integer, Cnt2 As Integer
Dim i As Integer, J As Integer
Set d = CreateObject("SCRIPTING.DICTIONARY")
Set d2 = CreateObject("SCRIPTING.DICTIONARY")
Range("C:G").ClearContents '清除工作表4 C欄-->G欄
Range("E:E").Interior.ColorIndex = xlNone
LstB = [B65536].End(xlUp).Row
Cnt = 1
Cnt2 = 1
ArC = Array(35, 36, 37, 38)
'以下計算工作表1-> 工作表3 出現機率為80%的字母*****
For i = 1 To 3 '從 "工作表1" 到 "工作表3"
Sheets(i).Range("C:E").ClearContents '清除每一頁的 C欄-->E欄
With Sheets(i).[C1].Resize(Sheets(i).[B65536].End(xlUp).Row) '即[C1:Cxx]
.Cells = "=COUNTIF(C2,RC[-1])/COUNTA(C1)"
'[C1]公式 = COUNTIF(B:B,B1)/COUNTA(A:A), 即計算每個字母出現的機率
AR(i) = Application.Transpose(.Offset(, -1).Resize(, 2).Value)
'將 B欄,C欄轉置為 AR(1 to 2, 1 to 21)
'將英文字母出現百分比機率導入 AR(i)
For Each E In .Cells '歷遍每一頁的 [C1:Cxx]
d2.Item(E.Offset(, -1).Value) = E.Value
'將字母(Key)及機率(Item)全部存入字典d2 中(不論機率大小)
If E >= 0.8 Then d(E.Offset(, -1).Value) = E.Value
'將機率 >=80% 的字母及機率, 放到字典d 中
Next
.Cells = .Value '公式轉為值
If d.Count >= 1 Then
.Cells(1).Range("B1").Resize(d.Count) = Application.Transpose(d.keys) '傾倒字母到每頁的 [D1:Dxx]
.Cells(1).Range("C1").Resize(d.Count) = Application.Transpose(d.Items) '傾倒機率到每頁的 [E1:Exx]
'★這裡若將 .Range("B1") 改為 .[B1]
' 則會出現 "物件不支援屬性或方法" 的錯誤!!
End If
If d2.Count >= 1 Then
'固定式(工作表4的A欄及B欄的表格事先填好)
'***工作表4上 B欄位中，每個英文字母出現在指定工作表的比率***
M = Application.Match(Sheets(i).Name, [A:A])
If IsNumeric(M) Then
If i = 3 Then
LstA = LstB
Else
LstA = Cells(M, 1).End(xlDown).Row - 1
End If
For J = M To LstA
If d2.Exists(Cells(J, 2).Value) Then
Cells(J, 3) = d2(Cells(J, 2).Value)
End If
Next
Cnt = LstA + 1
End If
'機動式(E欄(工作表名稱)及F欄(字母)的表格由VBA填入)
'***工作表4上 F欄位中，每個英文字母出現在指定工作表的比率***
Cells(Cnt2, 5) = Sheets(i).Name '工作表名稱
Cells(1).Range("E" & Cnt2).Resize(d2.Count).Interior.ColorIndex = ArC(i)
Cells(1).Range("F" & Cnt2).Resize(d2.Count) = Application.Transpose(d2.keys) '傾倒字母
Cells(1).Range("G" & Cnt2).Resize(d2.Count) = Application.Transpose(d2.Items) '傾倒機率
Cnt2 = d2.Count + 1
End If
End With
d.RemoveAll
d2.RemoveAll
Sheets(i).Range("C:C", "E:E").NumberFormatLocal = "0%" '數字格式化
Next
Range("C:C", "G:G").NumberFormatLocal = "0%" '數字格式化
End Sub

複製代碼