复杂的多表汇总(难度有点大,做出来有分加哦)

彭希仁 · 发表于 2010-1-20 22:53

加注释加分,大家都注上吧

泓() · 发表于 2010-1-21 08:00

原帖由 彭希仁 于 2010-1-20 22:53 发表
加注释加分,大家都注上吧

若我的代码加注释能否加分不然白加了

gljzyp · 发表于 2010-1-21 08:12

原帖由 彭希仁 于 2010-1-20 22:53 发表
加注释加分,大家都注上吧

版主决定是正确的！我们来学习的，支持加注释，高手跟上吧！

wenwen000424 · 发表于 2010-1-21 08:16

先向各位大师学习，我个人觉得通用性不够,现汇总表的A,B列与表头是先预置好的，通用的应是汇总表原为空白表，所有行列数据都是根据分表自动得出。对各位高手的挑战性也更大些。

[ 本帖最后由 wenwen000424 于 2010-1-21 08:18 编辑 ]

泓() · 发表于 2010-1-21 08:20

原帖由 wenwen000424 于 2010-1-21 08:16 发表
先向各位大师学习，我个人觉得通用性不够,现汇总表的A,B列与表头是先预置好的，通用的应是汇总表原为空白表，所有行列数据都是根据分表自动得出。对各位高手的挑战性也更大些。

言之有理支持

lichg888 · 发表于 2010-1-21 08:28

老师，也帮我做一下这个表的数据提取可以吗？

lichg888 · 发表于 2010-1-21 08:30

各位老师，也帮我写一个提取数据的代码可以吗？
提取数据的行列在附件里有说明了。

ccwan · 发表于 2010-1-21 08:34

我的代码其实很好理解，就是一般思路，一行行、一列列比对。
希望我的注释不会让大家糊涂了。

Const r = 4
'定义常量r=4，因为所有的行列都从4开始，这是为了程序的可读性，否则一直加3、加4不好理解
Sub cc()
Dim i&, j&, k&, m&, n&, x&, rng, Arr, brr, Sh As Worksheet, d As Object
Application.ScreenUpdating = False
'停止屏幕更新
Range(Cells(2, 2), Cells(2, 100)).Replace "Z", "V"
'将表格中第一行里的"Z"换成"V"
rng = [b1].CurrentRegion
'将总表中单元格区域传递给数组rng
For i = r To UBound(rng) - 1
If rng(i, 1) = "" Then rng(i, 1) = rng(i - 1, 1)
Next
'因为是合并单元格（例如广东，"A4:A14"，只有A4不为空），所以把省份为空值的变为与前一数值相同
For i = r To UBound(rng, 2) - 1
If rng(2, i) = "" Then rng(2, i) = rng(2, i - 1)
Next
'同上一段代码用途，这里是把手机机型为空的变为与前一数值相同
For Each Sh In ThisWorkbook.Sheets
'在各个表中循环
If Sh.Name <> "总表" Then
t = 0
'设置变量t为0
Set d = CreateObject("scripting.dictionary")
'建立字典，这是的字典用途和那几位老师的不同，只是为了方便剔除总表中有而分表中没有的机型，加快速度
Arr = Sh.[b1].CurrentRegion
'将分表中单元格区域传递给数组arr
For i = r To UBound(Arr) - 1
If Arr(i, 1) = "" Then Arr(i, 1) = Arr(i - 1, 1)
Next
'与总表中一样，把省份为空的变为与前一数值相同
For i = r To UBound(Arr, 2)
If Arr(2, i - 1) = "" Then Arr(2, i - 1) = Arr(2, i - 2)
d(Arr(2, i - 1) & Arr(3, i - 1)) = ""
Next
'与总表中一样，把机型为空的变为与前一数值相同，并把分表中的机型放入字典
'当总表中的机型分表中没有，则跳过，节省时间
n = 0
For k = r To UBound(rng, 2) - 1
m = 0
x = 0
y = 0
'设置变量m,x,y为0
'm是用来在数组rng中的纵列递增的
'x，y是用来在数组arr中的纵列递增的
'以上用法用来减少循环层数
Do While t < UBound(rng, 2) - 2
'它的意思不用说了，主要说明它的用途，因为我的代码就是让两个数组纵向比对之后，再横向比对
't就用来控制在数组rng的横向比对中不要出界，所以t的最大值是UBound(rng, 2) - 3
j = j + 1
'j是用来控制在数组rng的纵向比对中不要出界的，所以j的最大值是UBound(rng) - 3
Stop
If d.exists(rng(2, t + 2) & rng(3, t + 2)) Then
'当数组arr（分表）中包含rng（总表）中的机型与颜色（机型与颜色同时比对）时，继续运行下行代码
If j = UBound(rng) - 3 Then m = 0: n = n + 1: GoTo 0
'j达到最大值UBound(rng) - 3时，m清零，因为一个纵列中所有行已经比对完成了，下一列从头开始
'n的作用与t相同，将数组arr一列一列提取比对，接着运行标识“0”后面的代码
m = m + 1
If rng(r + m - 1, 1) & rng(r + m - 1, 2) = Arr(r + x, 1) & Arr(r + x, 2) Then
'当数组arr（分表）中与含rng（总表）中的省份与销售网点相同（省份与销售网点同时比对）时，继续运行下行代码
y = y + 1
If rng(2, t + 2) & rng(3, t + 2) = Arr(2, r + n - 1) & Arr(3, r + n - 1) Then
'当数组arr（分表）中与含rng（总表）中的机型与颜色相同时，继续运行下行代码
rng(m + 3, t + 2) = rng(m + 3, t + 2) + Arr(3 + y, r + n - 1)
'将数组arr中的销售数量与rng中省份与销售网点相同、机型与颜色相同的数量相加
'Cells(m + 3, t + 3) = Cells(m + 3, t + 3) + Arr(3 + y, r + n - 1)
'上面这行是当时测试代码时，在单元格中填充数值验证对错用的
x = x + 1
'x递增，继续比对arr中的某列中的下一行
End If
End If
Else
0
t = t + 1
x = 0
j = 0
y = 0
'列递数增加1，行递增数清零
End If
Loop
n = n + 1
If n = UBound(Arr, 2) Then n = 0
'当n达到最大值是，清零
Next
End If
Set d = Nothing
'清除字典中的内容，因为下一个工作表还要用
Next
[b1].Resize(UBound(rng) - 1, UBound(rng, 2) - 1) = rng
'填充数组rng到总表，但跳过最后一行和一列，因为它们有公式。
Range(Cells(2, 2), Cells(2, 100)).Replace "V", "Z"
'把总表中原先替换的再换回来
Application.ScreenUpdating = True
'打开屏幕更新
End Sub

复制代码

彭希仁 · 发表于 2010-1-21 08:39

原帖由 泓() 于 2010-1-21 08:00 发表

若我的代码加注释能否加分不然白加了

能啊,加吧,求你了,哈哈

alzeng · 发表于 2010-1-21 09:01

代码注释：

Sub DataSums()
Dim Arr, Ary, k%, icol%
Dim Sh As Worksheet, Str$
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Arr = Range("B2", [D65536].End(3).End(2).Offset(-1, -1)) '将本表有效范围的数据写入数组Arr
For k = 3 To UBound(Arr) '遍历数组中的数据行，将合并单元格造成的空值填上
If Arr(k, 1) = "" Then Arr(k, 1) = Arr(k - 1, 1)
Next
For icol = 3 To UBound(Application.Transpose(Arr)) '遍历数组中的数据列（维），将合并单元格造成的空值填上
If Arr(1, icol) = "" Then Arr(1, icol) = Arr(1, icol - 1)
If Left(Arr(1, icol), 1) Like "[A-Z]" Then Arr(1, icol) = Right(Arr(1, icol), Len(Arr(1, icol)) - 1) '去掉字母，以保障型号吻合
Next
For Each Sh In Sheets '遍历工作表
If Sh.Name <> ActiveSheet.Name Then '判定为非当前工作表时
Ary = Sh.Range("B2", Sh.[D65536].End(3).End(2).Offset(-1, -1)) '将本表有效范围的数据写入数组Ary
For k = 3 To UBound(Ary) '遍历数组中的数据行，将合并单元格造成的空值填上
If Ary(k, 1) = "" Then Ary(k, 1) = Ary(k - 1, 1)
Next
For icol = 3 To UBound(Application.Transpose(Ary)) 遍历数组中的数据列（维），将合并单元格造成的空值填上
If Ary(1, icol) = "" Then Ary(1, icol) = Ary(1, icol - 1)
If Left(Ary(1, icol), 1) Like "[A-Z]" Then Ary(1, icol) = Right(Ary(1, icol), Len(Ary(1, icol)) - 1) '去掉字母，以保障型号吻合
Next
For k = 3 To UBound(Ary) '用两个循环将当前工作表中的求和区域的数值按区域、商家、型号、颜色的唯一性写入字典
For icol = 3 To UBound(Application.Transpose(Ary))
Str = Ary(k, 1) & Ary(k, 2) & " " & Ary(1, icol) & Ary(2, icol)
Dic(Str) = Dic(Str) + Ary(k, icol)
Next
Next
Erase Ary '清除数组
End If
Next
Ary = Range("D4", [D65536].End(3).End(2).Offset(-1, -1)) 'Ary的范围即当前工作表的求和范围
For k = 1 To UBound(Ary)
For icol = 1 To UBound(Application.Transpose(Ary))
Ary(k, icol) = Dic(Arr(k + 2, 1) & Arr(k + 2, 2) & " " & Arr(1, icol + 2) & Arr(2, icol + 2)) '用查字典的方法将Ary中的每一个值查找出来
Next
Next
Dic.RemoveAll '清除字典
[D4].Resize(k - 1, UBound(Application.Transpose(Ary))) = Ary '将Ary数组写入求和区域
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[讨论] 复杂的多表汇总(难度有点大,做出来有分加哦)

回复 35楼泓() 的帖子

评分

[讨论] 复杂的多表汇总(难度有点大,做出来有分加哦)

回复 35楼 泓() 的帖子

评分

回复 35楼泓() 的帖子