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

wenwen000424 · 发表于 2010-1-25 06:26

原帖由 ldy 于 2010-1-25 05:22 发表
这个表的格式算是相当规范的了，按照关键字两个“合计” 可以定位区域。
就是设置总表格式很烦人。

656082

相当不错，汇总表中表头已经处理好了，A列只要加入一下合并相同内容单元格语句就可以了。希望给代码加注解。

ccwan · 发表于 2010-1-25 08:00

占位，学习ldy版主的代码

ldy · 发表于 2010-1-25 11:19

原帖由 wenwen000424 于 2010-1-25 06:26 发表

相当不错，汇总表中表头已经处理好了，A列只要加入一下合并相同内容单元格语句就可以了。希望给代码加注解。

简单点说，就是先通过代码规范数据，然后把双表头组成字符串，用字典记录行号、列标，再根据行号、列标累加到总表中。

总之通用性越强，代码量越大，通用性多1点，代码量起码要多 3 点。

'引用 Microsoft Scripting Runtime C:\WINDOWS\system32\scrrun.dll
Sub 汇总()
Dim colDIC As New Dictionary, rowDIC As New Dictionary
'列字典与行字典分别是这样的字符串："V360|白色" "广东|GZ02"，用以确定唯一性。
Dim rg As Range
Dim a As Variant, b As Variant, brr() As Variant
' a 是汇总后的数组， b 是每个月的数据数组，通过 "确定区域" 函数取值并规范。brr 把b 装在一起，便于引用
Dim k As Long, i As Long, j As Long, shcount As Integer
Application.ScreenUpdating = False '关闭屏幕刷新提高运行速度
t = Timer ' 开始计时
'取得每月销售表的数据区域，装到brr 中，并确定唯一的行标志（"广东|GZ02"）和列标志（"V360|白色"）
For k = 1 To Sheets.Count
If Sheets(k).Name Like "*销量" Then
shcount = shcount + 1
b = 确定区域(Sheets(k))
ReDim Preserve brr(1 To shcount)
brr(shcount) = b
For i = 3 To UBound(b, 2)
colDIC(b(1, i) & "|" & b(2, i)) = 0
Next
For i = 3 To UBound(b, 1)
rowDIC(b(i, 1) & "|" & b(i, 2)) = 0
Next
End If
Next
' 取数据完成
' 根据列字典与行字典设置总表，设置总表格式
Dim temp1 As Range, temp2 As Range
With Sheets("总表")
Sheets("总表").Cells.Delete
crr = colDIC.Keys '取得列标志数组
rrr = Application.WorksheetFunction.Transpose(rowDIC.Keys) '取得行标志数组
Set temp1 = .Range("d2").Resize(1, colDIC.Count)
temp1 = crr ' 填写列标志
For Each rg In temp1 ' 把列标志拆分成两行
rg.Cells(2, 1) = Split(rg, "|")(1)
rg = Split(rg, "|")(0)
Next
temp1.Resize(2).Sort Key1:=.Range("D2"), Orientation:=xlSortRows ' 利用Excel排序功能进行列标志横向排序
Set temp2 = .Range("b4").Resize(rowDIC.Count, 1)
temp2 = rrr ' 填写行标志
For Each rg In temp2 ' 把列标志拆分成两列
rg.Cells(1, 2) = Split(rg, "|")(1)
rg = Split(rg, "|")(0)
Next
temp2.Resize(, 2).Sort Key1:=.Range("b4"), Orientation:=xlSortColumns ' 利用Excel排序功能进行行标志纵向排序
Range(.Range("b2"), .Cells(temp2.Rows.Count + 4, temp1.Columns.Count + 4)).Borders.Weight = 2 '总表区域画上框框边线
.Range("b2:b3").Merge ' 合并单元格并填上表头
.Range("c2:c3").Merge
.Range("b2") = "省份"
.Range("c2") = "销售网点"
With .Cells(2, temp1.Columns.Count + 4).Resize(2)
.Merge
.Value = "合计"
End With
With .Cells(temp2.Rows.Count + 4, 2).Resize(, 2)
.Merge
.Value = "合计"
End With
Set v = temp1(1, 1)
For Each rg In temp1.Resize(, temp1.Columns.Count + 1) ' 扩展一列把相同型号的单元格合并
If v <> rg Then
s = v.Value
Range(v, rg.Cells(1, 0)) = Empty
Range(v, rg.Cells(1, 0)).Merge
Range(v, rg.Cells(1, 0)) = s
Set v = rg
End If
Next
Set v = temp2(1, 1)
For Each rg In temp2.Resize(temp2.Rows.Count + 1) ' 扩展一行把相同地区的单元格合并 90 楼的附件中忘了这一步
If v <> rg Then
s = v.Value
Range(v, rg.Cells(0, 1)) = Empty
Range(v, rg.Cells(0, 1)).Merge
Range(v, rg.Cells(0, 1)) = s
Set v = rg
End If
Next
End With
' '''''''' 设置总表格式结束
a = 确定区域(Sheets("总表"), rg) ' 取得设置好的总表区域数组 a
For i = 3 To UBound(a, 1)
rowDIC(a(i, 1) & "|" & a(i, 2)) = i ' 记录列标志在数组 a 中的列序号
Next
For i = 3 To UBound(a, 2)
colDIC(a(1, i) & "|" & a(2, i)) = i ' 记录行标志在数组 a 中的行序号
Next
For Each b In brr '把brr中的每一项传到合并过程,进行合并、累加完成汇总
进行合并 a, b, colDIC, rowDIC
Next
rg.Value = a '填写汇总结果
' 填写合计公式，以便验证
Set rg = rg.Resize(rg.Rows.Count + 1, rg.Columns.Count + 1)
For i = 3 To rg.Rows.Count
rg.Cells(i, rg.Columns.Count) = "=SUM(RC[-" & rg.Columns.Count - 3 & "]:RC[-1])"
Next
For i = 3 To rg.Columns.Count
rg.Cells(rg.Rows.Count, i) = "=SUM(R[-" & rg.Rows.Count - 3 & "]C:R[-1]C)"
Next
Application.ScreenUpdating = True
MsgBox Timer - t ' 运行耗时约0.4秒，关闭屏幕刷新后0.18秒
End Sub
Function 确定区域(sh As Worksheet, Optional c As Range) As Variant
'这个表的格式算是相当规范的了，按照关键字两个“合计” 可以定位区域
Dim a As Range, b As Range
Dim arr As Variant, v As Variant, x As Integer, y As Integer
Set a = sh.Cells.Find(What:="合*计", After:=sh.[a1]) ' 合*计预防 “ 合计 ”这类非规范写法
Set b = sh.Cells.FindNext(After:=a)
Set c = sh.Range(sh.Cells(a.Row, b.Column), sh.Cells(b.Row - 1, a.Column - 1))
arr = c.Value
x = c.Row
y = c.Column
'规范输入，合并的单元格中都填上相同内容
For i = 1 To c.Columns.Count
If c.Cells(1, i).MergeCells Then
If c.Cells(1, i).MergeArea.Count > 1 Then
v = c.Cells(1, i).MergeArea
For Each rg In c.Cells(1, i).MergeArea
arr(rg.Row - x + 1, rg.Column - y + 1) = v(1, 1)
Next
i = i + c.Cells(1, i).MergeArea.Columns.Count - 1
End If
End If
Next
For i = 2 To c.Rows.Count
If c.Cells(i, 1).MergeCells Then
If c.Cells(i, 1).MergeArea.Count > 1 Then
v = c.Cells(i, 1).MergeArea
For Each rg In c.Cells(i, 1).MergeArea
arr(rg.Row - x + 1, rg.Column - y + 1) = v(1, 1)
Next
i = i + c.Cells(i, 1).MergeArea.Rows.Count - 1
End If
End If
Next
确定区域 = arr
End Function
Sub 进行合并(a As Variant, b As Variant, colDIC As Dictionary, rowDIC As Dictionary)
Dim colstr As String, rowstr As String
'根据销售表（ b )中的行标志和列标志，通过行字典和列字典找到总表(a)中的行号与列号，并累加到总表中
For i = 3 To UBound(b, 1)
rowstr = b(i, 1) & "|" & b(i, 2) '组成行标志 "广东|GZ02"
For j = 3 To UBound(b, 2)
colstr = b(1, j) & "|" & b(2, j) '组成列标志（"V360|白色"）
r = rowDIC(rowstr) ' r 行号
c = colDIC(colstr) ' c 列号
a(r, c) = a(r, c) + b(i, j) ' 累加
Next
Next
End Sub

复制代码

彭希仁 · 发表于 2010-1-25 11:33

哈哈，所以这题的难度其实非常大，可以说是无上限的难题。

ldy · 发表于 2010-1-25 12:11

原帖由 彭希仁 于 2010-1-25 11:33 发表
哈哈，所以这题的难度其实非常大，可以说是无上限的难题。

严重同意，程序员考虑的再细致，也不能囊括所有用户输入时犯的错误。
比如同义词的问题合计-累计-统计，咖啡色-褐色-土黄色，黑色-纯黑-黑
再比如繁简体广东-廣東，有些数字用汉字表示 12 - 一打，10 -拾
还有其他更离谱的，如果都能想到并加以处理，程序员怕要吐血而亡了。

ldy · 发表于 2010-1-25 12:55

原帖由 彭希仁 于 2010-1-23 11:09 发表

这题的有两个意义
一、是送点分，现在竟赛那边没有分捞了，总得让大家增收吧。
二、引导大家开发插件的思路。这是最难的。要写成通用插件要走的路还很远，各件乱七八糟的情况都要想办法去解决，如在没有“汇 ...

才看到这个，最近家里装修，乱的很，电脑都很少开。
彭兄的工作写代码多，遇到的问题花样也多，彭兄自己也可以在竞赛区出题目，呵呵辛苦辛苦

彭希仁 · 发表于 2010-1-25 15:29

原帖由 ldy 于 2010-1-25 12:11 发表

严重同意，程序员考虑的再细致，也不能囊括所有用户输入时犯的错误。
比如同义词的问题合计-累计-统计，咖啡色-褐色-土黄色，黑色-纯黑-黑
再比如繁简体广东-廣東，有些数字用汉字表示 12 - 一打，10 -拾 ...

所以啊，程序员要学会取舍。那些该要，那些不该要。

[ 本帖最后由彭希仁于 2010-1-25 15:31 编辑 ]

wenwen000424 · 发表于 2010-1-25 16:03

继续扩展成可选择多个文件含有多个这样工作表汇总可能更通用些。

彭希仁 · 发表于 2010-1-25 17:31

原帖由 wenwen000424 于 2010-1-25 16:03 发表
继续扩展成可选择多个文件含有多个这样工作表汇总可能更通用些。

是的，这是最基本的一个要求

kaiyuanmdf · 发表于 2010-1-25 19:58

没用字典试一下

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

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