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

fgwei

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

泓()

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

复制代码

lichg888

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

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

yanjie

用了一个自定义函数，使单元格值能顺利读入字典！希望检查一下汇总结果是否正确？
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)

2010-1-21 09:45 上传

点击文件名下载附件

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

自然的家

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

泓()

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

ccwan

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


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

正在看，这几天事情多。

lb_bn

请版主指点.
销量汇总.rar (27.29 KB, 下载次数: 166)

2010-1-21 11:32 上传

点击文件名下载附件

1. Sub bbb()
   
2.     Dim i&, ii&, y&, tmp$, arr1(), arr2(), arr3()
   
3.     Dim dic1 As Object, Sh As Object
   
4.    
   
5.     Set dic1 = CreateObject("scripting.dictionary")
   
6.    
   
7.     arr1 = garr("总表")
   
8.    
   
9.     '添加汇总字典key
   
10.     For i = 3 To UBound(arr1)
    
11.         For ii = 3 To UBound(arr1, 2)
    
12.             tmp = arr1(i, 1) & arr1(i, 2) & Mid(arr1(1, ii), 2) & arr1(2, ii)
    
13.             dic1(tmp) = 0
    
14.         Next
    
15.     Next
    
16.    
    
17.     '循环分表并汇总于字典item
    
18.     For Each Sh In ThisWorkbook.Sheets
    
19.         If Sh.Name <> "总表" Then
    
20.             arr2 = garr(Sh.Name)
    
21.             For i = 3 To UBound(arr2)
    
22.                 For ii = 3 To UBound(arr2, 2)
    
23.                     tmp = arr2(i, 1) & arr2(i, 2) & Mid(arr2(1, ii), 2) & arr2(2, ii)
    
24.                     If dic1.exists(tmp) Then dic1(tmp) = dic1(tmp) + arr2(i, ii)
    
25.                 Next
    
26.             Next
    
27.         End If
    
28.     Next
    
29.    
    
30.     '对号入坐汇总值
    
31.     arr3 = dic1.items
    
32.     For i = 3 To UBound(arr1)
    
33.         For ii = 3 To UBound(arr1, 2)
    
34.             arr1(i, ii) = arr3(y)
    
35.             y = y + 1
    
36.         Next
    
37.     Next
    
38.    
    
39.     Sheets("总表").[b2].Resize(UBound(arr1), UBound(arr1, 2)).Value = arr1
    
40. End Sub
    
41. 
    
42. Function garr(shn As String)              '重新填写表头,处理合并单元格数据
    
43.     Dim i&, arrTmp()
    
44.    
    
45.     With Sheets(shn)
    
46.         arrTmp = .[b2].Resize(.[b65536].End(3).Row - 2, .[iv2].End(1).Column - 2).Value   '取数
    
47.     End With
    
48.     For i = 4 To UBound(arrTmp)
    
49.         If Len(arrTmp(i, 1)) = 0 Then arrTmp(i, 1) = arrTmp(i - 1, 1)                     '填写表头
    
50.     Next
    
51.     For i = 4 To UBound(arrTmp, 2)
    
52.         If Len(arrTmp(1, i)) = 0 Then arrTmp(1, i) = arrTmp(1, i - 1)
    
53.     Next
    
54.     garr = arrTmp
    
55. End Function

复制代码

彭希仁

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

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

彭希仁

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