|
今天繼續接著昨天梁總的來
二、多列多條件匯總(字典與數組)
數據源：
商品名稱 型號 數量 利潤
A A1 2 200
A A1 3 100
C C1 4 40
A A2 3 50
B B2 2 60
F F1 2 30
F F2 3 30
R R1 4 20
R R1 5 60
F F1 2 100
B B1 3 120
C C2 4 40
B B2 5 80
A A1 2 200
A A3 3 100
C C1 4 40
A A2 3 50
B B2 2 60
F F1 2 30
F F2 3 30
R R1 4 20
R R1 5 60
F F1 2 100
B B1 3 120
C C2 4 40
B B2 5 80
匯總結果：
商品名稱 型號 數量 利潤
A A1 7 500
C C1 8 80
A A2 6 100
B B2 14 280
F F1 8 260
F F2 6 60
R R1 18 160
B B1 6 240
C C2 8 80
A A3 3 100
代碼：
Sub 多條件多列匯總()
Dim Brr(1 To 10000, 1 To 4) '構造一個數組，行數足夠多
Dim 行數 '定義變量行數
Dim arr, x As Integer, sr As String, k As Integer
Set d = CreateObject('scripting.dictionary') '創建一個字典
arr = Range('a2:d' & Cells(Rows.Count, 'd').End(xlUp).Row) '將數據區域輸入數組
For x = 1 To UBound(arr) '在數組內部循環
sr = arr(x, 1) & '-' & arr(x, 2) '因為是兩個條件做關鍵字，需要將兩列內容聯合
If d.Exists(sr) Then '如果關鍵字存在就累加數據
行數 = d(sr) '條目是行數
Brr(行數, 3) = Brr(行數, 3) arr(x, 3) '累加數據
Brr(行數, 4) = Brr(行數, 4) arr(x, 4)
Else
k = k 1 '如果關鍵字不存在計數器加1
d(sr) = k '將關鍵字的條目設為行數，方便以后取數
Brr(k, 1) = arr(x, 1) '將數據區域的數據輸入到Brr數組
Brr(k, 2) = arr(x, 2)
Brr(k, 3) = arr(x, 3)
Brr(k, 4) = arr(x, 4)
End If
Next x
Range('g2').Resize(k, 4) = Brr '將Brr數組導入到單元格
End Sub
##分隔線www.vbafans.com### 三、多條件匯總（字典嵌套數組）
要求：
在工作簿中一共有三張工作表，名稱分別為附一，附二，附三。要求把上述三個表中把附一到附三中所有省份（D列）為廣西，城市為（E列）為南寧的姓名出現次數超過1次以上（三個表中累計超過一次以上）的統計出來。
附三： 
最終結果：
諸有光 39 13 廣西 南寧 16 17
諸有光 35 13 廣西 南寧 16 17
諸有光 28 12 廣西 南寧 16 18
張世后 24 12 廣西 南寧 16 18
張世后 40 13 廣西 南寧 16 17
胡秀文 24 12 廣西 南寧 16 18
胡秀文 27 12 廣西 南寧 16 18
代碼：
Sub 多條件統計()
Dim d, arr(), n As Byte, sn As Byte
Dim 行數 As Integer, 工作表 As Byte, j As Byte, k As Integer, arrR() As String
Set d = CreateObject('scripting.dictionary') '創建字典
For sn = 1 To Worksheets.Count '遍歷工作簿中的工作表
If Sheets(sn).Name Like '附[一二三]' Then '如果工作表名稱符合條件則進行下一步
n = n 1 '記錄工作表個數，作為下一步數組的維數，方便以后取數
ReDim Preserve arr(1 To n) '重設數組維數
arr(n) = Sheets(sn).Range('a1').CurrentRegion.Value '把每個工作表的活動區域放入相應的數組
For i = 1 To UBound(arr(n), 1) '遍歷數組中的單元格
If Trim(arr(n)(i, 4)) = '廣西' And Trim(arr(n)(i, 5)) = '南寧' Then '如果第4列和第5列的值符合要求則進行下一步
If d.exists(arr(n)(i, 1)) Then '如果字典中已經存在關鍵字則進行下一步
ar = d(arr(n)(i, 1)) '將關鍵字的相應條目輸出到數組（條目為數組）
ar(2) = ar(2) 1 '將條目中最后一項紀錄次數的值增加1
d(arr(n)(i, 1)) = ar '將變更后的數組重新輸入字典的條目
k = k 1 '計數器增加1，方便以后存放結果的動態數組調整維數
ReDim Preserve arrR(1 To 7, 1 To k) '重設存放結果的動態數組的維數
For j = 1 To 7 '將符合條件的數據循環取數存放到結果數組（注意行列要相反）
arrR(j, k) = arr(n)(i, j)
Next j
If d(arr(n)(i, 1))(2) = 1 Then '上面是符合條件的第二條記錄，要把相應的第一條記錄也要存放到結果數組，判斷條件是條目的最后一項記錄次數的值為1，不能為>1)
k = k 1 '計數器增加1，方便以后存放結果的動態數組調整維數
ReDim Preserve arrR(1 To 7, 1 To k) '重設存放結果的動態數組的維數
行數 = d(arr(n)(i, 1))(1) '將符合條件的數據循環取數存放到結果數組,p是指定列數，q是指定工作表
工作表 = d(arr(n)(i, 1))(0)
For j = 1 To 7
arrR(j, k) = arr(工作表)(行數, j)
Next j
End If
Else
d(arr(n)(i, 1)) = Array(n, i, 0) '字典中沒有關鍵字就創建
End If
End If
Next i
End If
Next sn
Range('j1').Resize(k, 7) = WorksheetFunction.Transpose(arrR) '將結果數組輸出到區域
With Range('j1').Resize(k, 7).Borders
.LineStyle = xlContinuous
End With
ActiveWorkbook.Worksheets('附一').Sort.SortFields.Clear
ActiveWorkbook.Worksheets('附一').Sort.SortFields.Add Key:=Range('J1:J7'), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets('附一').Sort
.SetRange Range('J1:P7')
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
##分隔線www.vbafans.com### 四、匯總(字典套字典法)
代碼：
Sub 生成匯總() '字典套字典法
Dim arr As Variant, dic1 As Object, dc As Object, karr As Variant, item As Byte '聲明變量
Dim brr() As Variant, i As Long, j As Long
Set dic1 = CreateObject('scripting.dictionary') '創建字典對象
With Worksheets('數據庫')
arr = .Range('A2:U' & .Cells(.Rows.Count, 'U').End(xlUp).Row).Value
End With
For i = 1 To UBound(arr)
If Len(arr(i, 15)) > 0 Then '如果鄉鎮不為空
If Not dic1.Exists(arr(i, 15)) Then Set dic1(arr(i, 15)) = CreateObject('scripting.dictionary') '如果不存在鄉鎮字典就創建該鄉鎮的字典對象
dic1(arr(i, 15))(arr(i, 21)) = dic1(arr(i, 15))(arr(i, 21)) arr(i, 5) '在鄉鎮字典對象中添加關鍵字和條目（關鍵字是戶數，條目則是統計關鍵字對應的畝數）
End If
Next
karr = dic1.keys '把鄉鎮的字典對象導入到數據，用于下面代碼提取個鄉鎮字典對象的關鍵字和條目
For item = 0 To dic1.Count - 1 '循環鄉鎮字典對象
Set dc = dic1(karr(item)) '就把相應的鄉鎮字典對象賦予給臨時變量，用于后面提取相應的戶數與畝數
j = j 1 '計數
ReDim Preserve brr(1 To 3, 1 To j) '重置數組
brr(1, j) = karr(item) '數組寫入鄉鎮，是dic1字典的關鍵字
brr(2, j) = dc.Count '數組寫入戶數，等于鄉鎮字典的關鍵字數量
brr(3, j) = WorksheetFunction.Sum(dc.items) '數組寫入畝數，等于鄉鎮字典的條目數量的總和
Next
Worksheets('匯總').Range('A6').Resize(UBound(brr, 2), 3) = WorksheetFunction.Transpose(brr) '數組brr輸出到工作表
End Sub
##分隔線www.vbafans.com### 五、一個字典同時實現匯總和計數
數據源：
產品 金額
鋼筆 11
鋼筆 10
鋼筆 12
鉛筆 15
筆記本 15
筆記本 19
鉛筆 20
筆記本 10
圓珠筆 17
橡皮 11
鉛筆 12
鉛筆 14
結果：
產品 金額 數量
鋼筆 33 3
鉛筆 61 4
筆記本 44 3
圓珠筆 17 1
橡皮 11 1
代碼：
Sub text()
Dim arr As Variant
Dim I As Integer, dic As Object, brr() As Variant, j, itarr
Set dic = CreateObject('scripting.dictionary') '創建字典對象
arr = Range(Range('A2'), Cells(Rows.Count, 'B').End(xlUp)).Value
For I = 1 To UBound(arr) '遍歷數組中每一行
If Len(arr(I, 1)) > 0 Then '如果長度大于0
If dic.Exists(CStr(arr(I, 1))) Then '如果字典中存在此關鍵字
'那么在關鍵字原來的值的基礎上累加arr(I, 2)的值和計數，先把關鍵字原來的值坼分重新組合
dic(CStr(arr(I, 1))) = Split(dic(CStr(arr(I, 1))), ',')(0) arr(I, 2) & ',' & Split(dic(CStr(arr(I, 1))), ',')(1) 1
Else
'金額數量和計數合并成一個條目
dic(CStr(arr(I, 1))) = dic(CStr(arr(I, 1))) arr(I, 2) & ',' & 1
End If
End If
Next
itarr = dic.items '導出字典條目
For j = 0 To UBound(itarr) '遍歷數組，把字典條目坼分成一維數組再導出一個數組里
ReDim Preserve brr(1 To 2, 0 To j)
brr(1, j) = Split(itarr(j), ',')(0)
brr(2, j) = Split(itarr(j), ',')(1)
Next
Range('E1:G1') = Array('產品', '金額', '數量')
Range('E2').Resize(dic.Count, 1) = WorksheetFunction.Transpose(dic.Keys)
Range('F2').Resize(dic.Count, 2) = WorksheetFunction.Transpose(brr)
Range('E1').CurrentRegion.Borders.LineStyle = xlContinuous
End Sub
##分隔線www.vbafans.com### 六、字典vs數組去重復匯總
詳細要求請下載附件查看
代碼：
Sub 字典vs數組去重復匯總()
Dim d As Object, brr(), arr, its, sht As Worksheet, rng As Range, rn As Range
Dim i, j, m, k
On Error Resume Next
Set d = CreateObject('scripting.dictionary')
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> '匯總' Then 'Or IsEmpty(sht)
arr = sht.Range('a1').CurrentRegion.Value
For i = 1 To UBound(arr)
If Len(arr(i, 1)) > 0 Then
If d.exists(arr(i, 1)) Then '如果存在
its = d(arr(i, 1))
For m = 0 To UBound(its)
ReDim Preserve brr(0 To k)
brr(k) = its(m)
k = k 1
Next
For j = 2 To UBound(arr, 2)
If Len(arr(i, j)) > 0 Then
If UBound(Filter(its, arr(i, j), True, 1)) >= 0 Then ''如果兩者篩選后產生的數組上界大于等于0,那么表示存在相同項
Else
ReDim Preserve brr(0 To k)
brr(k) = arr(i, j)
k = k 1
End If
End If
Next
d(arr(i, 1)) = brr
Else '如果不存在
For j = 2 To UBound(arr, 2)
If Len(arr(i, j)) > 0 Then
ReDim Preserve brr(0 To k)
brr(k) = arr(i, j)
k = k 1
End If
Next
If k > 0 Then d(arr(i, 1)) = brr
End If
End If
Erase brr: k = 0
Next
End If
Next
Set rng = Intersect(Worksheets('匯總').Range('A:A'), Worksheets('匯總').UsedRange)
For Each rn In rng
If Len(rn) > 0 Then
its = d(CStr(rn))
If IsEmpty(its) = False Then
rn.Offset(0, 1).Resize(1, UBound(its) 1) = its
End If
End If
Next
End Sub ##分隔線www.vbafans.com### 七、字典條目數組用法
Sub test() '條目數組用法
Dim t
Set d = CreateObject('scripting.dictionary') '創建字典對象
With Sheets('data')
arr = .Range('a2:d' & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
For i = 1 To UBound(arr)
d(arr(i, 1)) = Array(arr(i, 2), arr(i, 3), arr(i, 4)) '添加字典關鍵字，條目是數組
j = d(arr(i, 1))
Next
[a2].Offset(1, 1).Resize(3) = Application.Transpose(d(CStr([a2]))) '導出關鍵字的條目，要轉換為文本
End Sub
好了~~~今天的字典就擼到這里了，，復雜的擼不出，簡單的擼得有點快。。。。。。更多的字典擼法，大家可以在平時多練習和總結。。。。
|
