|
今天继续接着昨天梁总的来
二、多列多条件汇总(字典与数组)
数据源：
商品名称 型号 数量 利润
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
好了~~~今天的字典就撸到这里了，，复杂的撸不出，简单的撸得有点快。。。。。。更多的字典撸法，大家可以在平时多练习和总结。。。。
|
