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

office2008 · 发表于 2010-1-25 21:31

看了ldy 版主的，确实具有一定的通用性了，通过MERGE来整合标题行，列以及查找两个合*计来获得表格的数据位置。
可改动的地方：用数组取得表数据，再按照前面已答出几种答案的网友数组方法判断来整合标题行,另外其他地方也都用数组解决,快点而已，当然这本身就是ldy 版主的这个全面高手的拿手好戏。也曾做过多工作簿多表不等行、列，就是没有做到行、列标题是复合的，这里只要多做一些手脚就可以了，当时记得是用SQL和字典两种方法分别做了，放到这题上字典仍旧可以解决，SQL就巨难了，如有谁用SQL挑战试试，我想彭总肯定会加分的，呵呵。

用数组套数组把所有工作簿的工作表数据全部一次取得，然后再细化吧。

只要有规律总的来说并不难，难就难在有些表与表之间相差太多，规律很勉强和模糊。

[ 本帖最后由 office2008 于 2010-1-25 21:34 编辑 ]

kaiyuanmdf · 发表于 2010-1-25 22:42

楼上说的是。我需对此再进一步的优化与改进。
下面说说对这个题的认识及解题思路，请指正。
这个工作簿是由一个总表和几张月表组成。看后发现，销售网点是唯一的，只是列标有合并单元格的现象，而总表在列标和行标上最全的，可以和其他几个表合并计算，可能不改变列标排序，做完后试了一下，可行。如果列标符合规范了，对表内数据的处理可以用consolidata方法来处理了，其sources参数指定合并计算的源数据区域，为字符串数组形式且必须是R1C1样式的引用。

hupanshan · 发表于 2010-1-26 14:05

汇总.rar (27.5 KB, 下载次数: 104)
费了很大劲，绣花一般编了个演示程序，可以支持纵向及横向分类层级的变化，目前我把每个方向的层级限制在1～3级。合计的事先不做了，累了。

[ 本帖最后由 hupanshan 于 2010-1-26 14:10 编辑 ]

wenwen000424 · 发表于 2010-1-26 14:59

原帖由 hupanshan 于 2010-1-26 14:05 发表
657073
费了很大劲，绣花一般编了个演示程序，可以支持纵向及横向分类层级的变化，目前我把每个方向的层级限制在1～3级。合计的事先不做了，累了。

请问表芯位置在哪?若是弄个弹出框，让使用者输入表头行数和左边条件列数可能更好。

hupanshan · 发表于 2010-1-26 15:20

原帖由 wenwen000424 于 2010-1-26 14:59 发表

请问表芯位置在哪?若是弄个弹出框，让使用者输入表头行数和左边条件列数可能更好。

无非是个演示程序，弄个弹出窗还要额外“绣花”，太累人。“表芯”是我自造的概念，就是除去上表头、左表头外，填写具体汇总数据的位置。
这个上传的文件按我的设想填好了“3*3”直接按汇总钮就可以了

汇总.rar (25.21 KB, 下载次数: 107)

wenwen000424 · 发表于 2010-1-26 20:47

原帖由 hupanshan 于 2010-1-26 15:20 发表

无非是个演示程序，弄个弹出窗还要额外“绣花”，太累人。“表芯”是我自造的概念，就是除去上表头、左表头外，填写具体汇总数据的位置。
这个上传的文件按我的设想填好了“3*3”直接按汇总钮就可以了657146

测试过了，不错。要好好学习一下代码。

office2008 · 发表于 2010-1-26 23:58

第一种：多簿多表不等复合行，列的字典法，请测试。

'引用 Microsoft Scripting Runtime 'C:\WINDOWS\system32\scrrun.dll
Sub 汇总()
Dim xDic As New dictionary, yDic As New dictionary
Dim filePath As String, fileName As String
Dim eBook As Workbook, eSheet As Worksheet
Dim xRng As Range, yRng As Range, zRng As Range, rng As Range
Dim rngArr() As Variant, arr() As Variant
Dim x As Integer, y As Integer, i As Integer, j As Integer
Dim m As Integer, n As Integer, Index As Integer
t = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
filePath = ThisWorkbook.Path & "\各部门销售"
fileName = Dir(filePath & "\*.xls")
Do While Len(fileName) > 0
Set eBook = Workbooks.Open(filePath & "" & fileName)
For Each eSheet In eBook.Sheets
If eSheet.Name Like "*销量" Then
Index = Index + 1
With eSheet ' 合*计预防“ 合计 ”这类非规范写法
Set xRng = .Cells.Find(What:="合*计", After:=.Range("a1"))
Set yRng = .Cells.FindNext(After:=xRng)
ReDim Preserve rngArr(1 To Index)
rngArr(Index) = .Range(.Cells(xRng.Row, yRng.Column), .Cells(yRng.Row - 1, xRng.Column - 1))
End With
End If
Next
eBook.Close False
fileName = Dir()
Loop
For Index = 1 To UBound(rngArr)
For i = 3 To UBound(rngArr(Index))
If rngArr(Index)(i, 1) = "" Then rngArr(Index)(i, 1) = rngArr(Index)(i - 1, 1)
If Not xDic.Exists(rngArr(Index)(i, 1) & "|" & rngArr(Index)(i, 2)) Then
x = x + 1
xDic(rngArr(Index)(i, 1) & "|" & rngArr(Index)(i, 2)) = x
End If
Next
For i = 3 To UBound(rngArr(Index), 2)
If rngArr(Index)(1, i) = "" Then rngArr(Index)(1, i) = rngArr(Index)(1, i - 1)
If Not yDic.Exists(rngArr(Index)(1, i) & "|" & rngArr(Index)(2, i)) Then
y = y + 1
yDic(rngArr(Index)(1, i) & "|" & rngArr(Index)(2, i)) = y
End If
Next
Next
ReDim arr(1 To x, 1 To y)
For Index = 1 To UBound(rngArr)
For i = 3 To UBound(rngArr(Index))
For j = 3 To UBound(rngArr(Index), 2)
m = xDic(rngArr(Index)(i, 1) & "|" & rngArr(Index)(i, 2))
n = yDic(rngArr(Index)(1, j) & "|" & rngArr(Index)(2, j))
arr(m, n) = arr(m, n) + rngArr(Index)(i, j)
Next
Next
Next
With Sheets("总表")
.Cells.Delete
Set xRng = .Range("b4").Resize(xDic.Count, 1)
xRng = Application.Transpose(xDic.Keys)
For Each rng In xRng
rng.Resize(, 2) = Split(rng, "|")
Next
Set yRng = .Range("d2").Resize(1, yDic.Count)
yRng = yDic.Keys
For Each rng In yRng
rng.Resize(2) = Application.Transpose(Split(rng, "|"))
Next
.Range("d4").Resize(xDic.Count, yDic.Count) = arr
Set zRng = .Range("d2").Resize(xDic.Count + 2, yDic.Count)
zRng.Sort Key1:=.Range("D2"), Orientation:=xlSortRows
Set zRng = .Range("b4").Resize(xDic.Count, yDic.Count + 2)
zRng.Sort Key1:=.Range("b4"), Orientation:=xlSortColumns
x = 0
For Each rng In xRng
If rng.Text <> rng.Offset(1).Text Then
If x > 0 Then rng.Offset(-x).Resize(x + 1).Merge
x = 0
Else
x = x + 1
End If
Next
y = 0
For Each rng In yRng
If rng.Text <> rng.Offset(, 1).Text Then
If y > 0 Then rng.Offset(, -y).Resize(1, y + 1).Merge
y = 0
Else
y = y + 1
End If
Next
.Range("b2:b3").Merge
.Range("c2:c3").Merge
.Range("b2") = "省份"
.Range("c2") = "销售网点"
With .Cells(2, yDic.Count + 4).Resize(2)
.Merge
.Value = "合计"
End With
With .Cells(xDic.Count + 4, 2).Resize(, 2)
.Merge
.Value = "合计"
End With
Set rng = Range("b2").Resize(xDic.Count + 3, yDic.Count + 3)
rng.Borders.LineStyle = True
For i = 3 To xDic.Count + 3
rng.Cells(i, yDic.Count + 3) = "=SUM(RC[-" & yDic.Count + 3 - 3 & "]:RC[-1])"
Next
For i = 3 To yDic.Count + 3
rng.Cells(xDic.Count + 3, i) = "=SUM(R[-" & xDic.Count + 3 - 3 & "]C:R[-1]C)"
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub

复制代码

为上面这些代码已经用了4个多小时了
第二种：多簿多表不等复合行，列的SQL法，已经解决复合行和复合列标题（域函数），有空再做。

彭希仁：非常不错，能想到多工作薄，但离傻瓜式还有差距，你的东西只能给会VBA的人使用。

[ 本帖最后由彭希仁于 2010-1-29 17:32 编辑 ]

hupanshan · 发表于 2010-1-27 09:16

汇总.rar (27.31 KB, 下载次数: 164)

彭希仁：非常不错，但离傻瓜式还有差距，你的东西只能给会VBA的人使用。

[ 本帖最后由彭希仁于 2010-1-29 17:34 编辑 ]

彭希仁 · 发表于 2010-1-29 17:28

非常不错，在通用性方面，有了很大的提高，但是离我期望的目标还相差很远，希望大家站在用户的角度去想想他们能用不。

wenwen000424 · 发表于 2010-1-30 08:15

原帖由 彭希仁 于 2010-1-29 17:28 发表
非常不错，在通用性方面，有了很大的提高，但是离我期望的目标还相差很远，希望大家站在用户的角度去想想他们能用不。

同意，以上的程序都只是针对版主提供的特定表格，换了其它含有合并单元格的表格就需修改代码。

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

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

回复 100楼 kaiyuanmdf 的帖子

评分

103楼的程序有个缺陷，补上了，对说明做了点改进

评分

评分