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

fgwei · 发表于 2010-1-21 09:10

看到此帖，真是如获至宝，有注释，对我们菜鸟真好，谢谢各位高手了！

泓() · 发表于 2010-1-21 09:25

Sub 泓()
Application.ScreenUpdating = False
[2:2].Replace "Z", "V" '替换
Set d = CreateObject("scripting.dictionary") '创建字典d
For n = 1 To 4 '循环
With Sheets(n) '工作表 1、2、3、4
Cell = .[b2].Resize(.[b65536].End(xlUp).Row - 2, .[iv2].End(xlToLeft).Column - 2) '单元格区域数组
For i = 3 To UBound(Cell) '第一维可用的最大下标
If Cell(i, 1) = "" Then Cell(i, 1) = Cell(i - 1, 1) '应付合并单元格
For j = 3 To UBound(Cell, 2) '第二维可用的最大下标
If Cell(1, j) = "" Then Cell(1, j) = Cell(1, j - 1) '应付合并单元格
c = Cell(i, 1) & Cell(i, 2) & Cell(1, j) & Cell(2, j) 'c,如题中的"广东"&"GZ02"&"V390"&"白色"="广东GZ02V390白色"
If n = 1 Then '若是汇总表'想想看.为什么说这里降低了运行的速度;为了代码的层高
If Not d.exists(c) Then d.Add c, Empty '若字典d.Keys中不存在c,则添加Key值c,其Item值为Empty[空]
Else '其它工作表,分表
If d.exists(c) Then d(c) = d(c) + Cell(i, j) '若字典d.Keys中存在c,也就是汇总表中存在c, 对应的Item值=原Item值+分表对应的单元格值;实际上是计数
End If
Next
Next
End With
If n = 1 Then a = UBound(Cell) - 2: b = UBound(Cell, 2) - 2 '汇总表赋值区域的行数a,列数b
Next
ReDim r(1 To a, 1 To b) '重定义一个二维数组
s = d.Items '字典的Items赋于s
For i = 0 To d.Count - 1 '遍及数组,d.Count字典的条目数
r(i \ b + 1, i Mod b + 1) = s(i) '一维s转二维数组r
Next
[2:2].Replace "V", "Z" '替换
[d4].Resize(a, b) = r '数组r赋值单元格区域
Set d = Nothing
Application.ScreenUpdating = True
End Sub

复制代码

lichg888 · 发表于 2010-1-21 09:31

原帖由 ccwan 于 2010-1-21 08:34 发表
我的代码其实很好理解，就是一般思路，一行行、一列列比对。
希望我的注释不会让大家糊涂了。Const r = 4
'定义常量r=4，因为所有的行列都从4开始，这是为了程序的可读性，否则一直加3、加4不好理解
Sub cc ...

老师，能不能也帮我整一段代码实现数据提取功能呀？

yanjie · 发表于 2010-1-21 09:36

用了一个自定义函数，使单元格值能顺利读入字典！希望检查一下汇总结果是否正确？
Option Explicit
Sub ClearRange()
Dim ws As Worksheet, d As Scripting.Dictionary
Dim k&, j&, R&, L&, mystr$
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Sheet1.[d4:ai127] = ""
For Each ws In Worksheets(Array("一月份销量", "二月份销量", "三月份销量", "总表"))
'在工作表之间循环,让"总表"处于最后一个工作表!
ws.Select
R = [b65536].End(xlUp).Row - 1: L = Range("iv2").End(xlToLeft).Column - 1
'取当前工作表最后行号和列号！
'下面代码利用自定义函数，读入字典！
For k = 4 To R
      For j = 4 To L
         mystr = myrange(Cells(k, 2)).Value & Cells(k, 3).Value & myrange(Cells(2, j)).Value & Cells(3, j).Value
         If d.Exists(mystr) Then
         d.Item(mystr) = d.Item(mystr) + Cells(k, j).Value
         Else
         d.Item(mystr) = Cells(k, j).Value
         End If
            If ws.Name = "总表" Then
                  If d.Exists(mystr) Then Cells(k, j).Value = d.Item(mystr)
            End If
      Next j
Next k
Next ws
Application.ScreenUpdating = True
Set d = Nothing
End Sub
Function myrange(c As Range) As Range
If c.MergeArea.Cells.Count > 1 Then
Set myrange = c.MergeArea.Cells(1, 1)
Else
Set myrange = c
End If
End Function

销量汇总_20100120UDF.rar (28.3 KB, 下载次数: 164)

[ 本帖最后由 yanjie 于 2010-1-21 09:46 编辑 ]

自然的家 · 发表于 2010-1-21 09:44

谢谢各位老师。我先收藏了，因为刚学VBA还不能完全消化。怎么样才能通用到其它项目上面，我还要想想。。在一次谢谢你们辛勤的付出。

泓() · 发表于 2010-1-21 09:48

以前竞赛区被LDY扣了技术分1分好想好想在本题捞回1分彭总能如愿以偿吗

ccwan · 发表于 2010-1-21 09:51

原帖由 lichg888 于 2010-1-21 09:31 发表

老师，能不能也帮我整一段代码实现数据提取功能呀？

正在看，这几天事情多。

lb_bn · 发表于 2010-1-21 11:32

请版主指点.

销量汇总.rar (27.29 KB, 下载次数: 166)

Sub bbb()
Dim i&, ii&, y&, tmp$, arr1(), arr2(), arr3()
Dim dic1 As Object, Sh As Object
Set dic1 = CreateObject("scripting.dictionary")
arr1 = garr("总表")
'添加汇总字典key
For i = 3 To UBound(arr1)
For ii = 3 To UBound(arr1, 2)
tmp = arr1(i, 1) & arr1(i, 2) & Mid(arr1(1, ii), 2) & arr1(2, ii)
dic1(tmp) = 0
Next
Next
'循环分表并汇总于字典item
For Each Sh In ThisWorkbook.Sheets
If Sh.Name <> "总表" Then
arr2 = garr(Sh.Name)
For i = 3 To UBound(arr2)
For ii = 3 To UBound(arr2, 2)
tmp = arr2(i, 1) & arr2(i, 2) & Mid(arr2(1, ii), 2) & arr2(2, ii)
If dic1.exists(tmp) Then dic1(tmp) = dic1(tmp) + arr2(i, ii)
Next
Next
End If
Next
'对号入坐汇总值
arr3 = dic1.items
For i = 3 To UBound(arr1)
For ii = 3 To UBound(arr1, 2)
arr1(i, ii) = arr3(y)
y = y + 1
Next
Next
Sheets("总表").[b2].Resize(UBound(arr1), UBound(arr1, 2)).Value = arr1
End Sub
Function garr(shn As String) '重新填写表头,处理合并单元格数据
Dim i&, arrTmp()
With Sheets(shn)
arrTmp = .[b2].Resize(.[b65536].End(3).Row - 2, .[iv2].End(1).Column - 2).Value '取数
End With
For i = 4 To UBound(arrTmp)
If Len(arrTmp(i, 1)) = 0 Then arrTmp(i, 1) = arrTmp(i - 1, 1) '填写表头
Next
For i = 4 To UBound(arrTmp, 2)
If Len(arrTmp(1, i)) = 0 Then arrTmp(1, i) = arrTmp(1, i - 1)
Next
garr = arrTmp
End Function

复制代码

彭希仁 · 发表于 2010-1-21 11:41

原帖由 泓() 于 2010-1-21 09:48 发表
以前竞赛区被LDY扣了技术分1分好想好想在本题捞回1分彭总能如愿以偿吗

只要能做到通用,我加两分

彭希仁 · 发表于 2010-1-21 11:45

通知,后面的不再加分了,因为很多答案和前面的差不多.

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

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

简要注释

评分