1-12月 不同表头标题（字段）数据合并(非常感谢zhaogang1960等老师)

kszcs

http://club.excelhome.net/thread-733406-2-1.html###
16楼的那个，C列相同的姓名对应的数据，汇总时能合计在一起吗？

zhaogang1960

原帖由 kszcs 于 2011-6-26 20:04 发表
http://club.excelhome.net/thread-733406-2-1.html###
16楼的那个，C列相同的姓名对应的数据，汇总时能合计在一起吗？

没有问题，不过这样一来第一、二列要求写工作簿、工作表名就没有意义了，下面代码已经把这个功能注释化了，如果你需要去掉撇号就可以了：
Sub Macro1()
    Dim arrpath$(), arr, brr(), sh As Worksheet, i&, j&, m&, n&, k&, d As Object, ds As Object
    Dim myPath$, myFile$, wb As Workbook, s$, w$
    Set d = CreateObject("scripting.dictionary")
    Set ds = CreateObject("scripting.dictionary")
'    d("工作簿") = 1
'    d("工作表") = 2
'    m = 2
    Set wb1 = ThisWorkbook
    Application.ScreenUpdating = False
    myPath = ThisWorkbook.Path & "\数据源\"
    myFile = Dir(myPath & "*.xls")
    Do While myFile <> ""
            n = n + 1 '工作簿计数
            ReDim Preserve arrpath(1 To n) '重新定义工作簿路径数组
            arrpath(n) = myPath & myFile '记录工作簿路径
            Set wb = GetObject(arrpath(n)) '调用这个工作簿
            For Each sh In wb.Sheets
                With sh
                    If IsSheetEmpty = IsEmpty(.UsedRange) Then
                        arr = .[b3].Resize(.[b65536].End(xlUp).Row - 2, .[iv3].End(xlToLeft).Column - 1)
                        For j = 1 To UBound(arr, 2)
                            If Not d.Exists(arr(1, j)) Then
                                m = m + 1
                                d(arr(1, j)) = m
                            End If
                        Next
                    End If
                End With
            Next
            wb.Close False
        myFile = Dir
    Loop
    ReDim brr(1 To 60000, 1 To d.Count)
    m = 0
    For k = 1 To n '逐个工作簿
'        w = Split(Split(arrpath(k), "\")(UBound(Split(arrpath(k), "\"))), ".")(0)
        Set wb = GetObject(arrpath(k)) '调用工作簿
        For Each sh In wb.Sheets
            With sh
                If IsSheetEmpty = IsEmpty(.UsedRange) Then
'                    s = .Name
                    arr = .[b3].Resize(.[b65536].End(xlUp).Row - 2, .[iv3].End(xlToLeft).Column - 1)
                    For i = 2 To UBound(arr)
                        If Not ds.Exists(arr(i, 2)) Then
                            m = m + 1
                            ds(arr(i, 2)) = m
'                            brr(m, 1) = w
'                            brr(m, 2) = s
                            For j = 1 To UBound(arr, 2)
                                brr(m, d(arr(1, j))) = arr(i, j)
                            Next
                        Else
                            For j = 3 To UBound(arr, 2)
                                brr(ds(arr(i, 2)), d(arr(1, j))) = brr(ds(arr(i, 2)), d(arr(1, j))) + arr(i, j)
                            Next
                        End If
                    Next
                End If
            End With
        Next
        wb.Close False
    Next
    ActiveSheet.UsedRange.ClearContents
    [a1].Resize(, d.Count) = d.Keys
    [a2].Resize(m, d.Count) = brr
    Application.ScreenUpdating = True
    MsgBox "汇总完毕"
End Sub

多工作簿，同格式不同标题汇总.rar (37.56 KB, 下载次数: 234)

2011-6-26 22:08 上传

点击文件名下载附件

商人

赵刚老师太牛了！
你怎么啥都能来，数组、字典、VBA 、SQL、透视表。。。

kszcs

功底深厚，兼备大师的风范

qdchyq

你好赵老师，假如数据放在A1单元格呢

zhaogang1960

原帖由 qdchyq 于 2011-6-27 10:38 发表
你好赵老师，假如数据放在A1单元格呢

这就符合数据库规律了，只需要把A1的当前区域赋给数组即可：
arr=.[a1].currentregion

joyark

非常感谢！

kszcs

zhaogang1960 老师你好：
各个分表的数据从B8开始，
把arr = .[b3].    改为arr = .[b8].
怎么不能运行呀
谢谢

zhaogang1960

arr = .[b8].Resize(.[b65536].End(xlUp).Row - 7, .[iv8].End(xlToLeft).Column - 1)

kszcs

谢谢zhaogang1960 老师，忽略了.[iv8].