本帖最后由 佛山小老鼠 于 2013-11-3 16:50 编辑
第一个案例:
1.多行2列分类汇总
2.多行多列分类汇总
- Option Explicit
- Sub 二列多行()
- Dim arr1, dic, x, arr2(1 To 10, 1 To 2), m%, k% '定义变量
- Set dic = CreateObject("Scripting.dictionary") '后期绑定引用字典
- arr1 = Range("A1").CurrentRegion '把单元区域装到数组arr1
- For x = 2 To UBound(arr1, 1) '循环数组arr1的行
- If dic.exists(arr1(x, 1)) Then '判断数组元素arr1(x,1)在字典关键词里是否存在,
- m = dic(arr1(x, 1)) '如果存在,把关键词arr1(x,1)的条目读出来,在原来的
- '基础上累加,通过读取关键词arr1(x,1)的条目,找到在数组arr2那一行上累加
- arr2(m, 2) = arr2(m, 2) + arr1(x, 2) '在数组arr2第m行,第2列上累加
- Else '如果关键词arr1(x,1)不存在,那么
- k = k + 1 '计数
- dic(arr1(x, 1)) = k '把数组arr1(x,1)装到字典dic里,条目装一个k,
- '这个k的作用来给数组arr2中找到存放那一行
- arr2(k, 1) = arr1(x, 1) '把数组arr1里的第x行第1列装到数组arr2的第k行,第1列
- arr2(k, 2) = arr1(x, 2) '把数组arr1里的第x行第2列装到数组arr2的第k行,第2列
- End If
- Next x
- Range("E1:F" & Rows.Count) = "" '清空区域,用来存放新的数据
- [E1:F1] = Array("产品名称", "数量") '填充表头
- [E2].Resize(k, 2) = arr2 '把数组arr2读到单元格区域
- End Sub
- Sub 多列多行汇总()
- Dim dic, arr1, x%, MySt, k%, arr2(1 To 15, 1 To 3), y%, m%
- Set dic = CreateObject("Scripting.dictionary")
- arr1 = Range("A1").CurrentRegion
- For x = 2 To UBound(arr1, 1)
- MySt = arr1(x, 1) & arr1(x, 2)
- If dic.exists(MySt) Then
- m = dic(MySt)
- arr2(m, 3) = arr2(m, 3) + arr1(x, 3)
- Else
- k = k + 1
- dic(MySt) = k
- For y = 1 To 3
- arr2(k, y) = arr1(x, y)
- Next y
- End If
- Next x
- Range("E1:G" & Rows.Count) = ""
- [E1:G1] = Array("产品名称", "款号", "数量")
- [E2].Resize(k, 3) = arr2
- End Sub
- Sub 清空1()
- Range("E1:F" & Rows.Count) = ""
- End Sub
-
- Sub 清空2()
- Range("E1:G" & Rows.Count) = ""
- End Sub
复制代码 第二个代码我就不加注解了,同第一个代码差不多,区别是
由于关键字只能装1列,如果有多列怎么办呢?
我们可以把多列用&串起来,多串字符串就变成了一串字符串
附件在第1楼
|