用SQL把列名不完全相同的多个工作簿合并和汇总

office2008

'年前做了个单个工作簿的,有朋友要求要加注释,我就不在单个工作簿上加注释了, _
昨天想起自己还没有完成的事（多工作簿多表不等列 SQL 汇总） _
现在我用 SQL方法做了个多工作簿多表不等列的例子, 里面加了注释, 不用SQL方法应该也可以的.

'我只是举个例子,并不完善思路也不好,希望高手指点

'####################

'（缺点）工作表数目有限制，速度太慢

'(wxyqxxz2007,office2008)
'####################

Dim arr()
Dim d As New Scripting.dictionary
Dim d2 As New Scripting.dictionary
Dim p As String
Dim sql2 As String

Private Sub CheckBox1_Click()
    For i = 1 To ListView1.ListItems.Count
        If CheckBox1.Value Then                        '全选
            ListView1.ListItems(i).Checked = True         '选中所有元素
        Else
            ListView1.ListItems(i).Checked = False        '取消所有选中
        End If
    Next
End Sub

Private Sub CommandButton1_Click()
    Dim arra()
    Set cn = CreateObject("ADODB.Connection")
    cn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0;imex=1';Data Source=" & ThisWorkbook.FullName
    z = 0
    With UserForm1.ListView1
        For j = 1 To .ListItems.Count
            If .ListItems(j).Checked = True Then
                z = z + 1
                ReDim Preserve arra(1 To z)                      '储存循环 select 语句
                For i = 0 To UBound(arr) - 1                   '在合计字段之前
                    If InStr(d2(.ListItems(j).Text & .ListItems(j).SubItems(1)), arr(i) & ",") Then   '在第二个字典中查找有或没有,不同工作簿不同工作表为参照
                        arra(z) = arra(z) & arr(i) & ","                                              '有就不需要 '' as 字段 语句
                    Else
                        arra(z) = arra(z) & "'' as " & arr(i) & "" & ","                              '没有需要添加 '' as 字段 语句
                    End If
                Next
                arra(z) = " select " & Left(arra(z), Len(arra(z)) - 1) & ",合计 " _
                & " from [Excel 8.0;DATABASE=" & p & .ListItems(j).Text & "].[" & .ListItems(j).SubItems(1) & "$] "  '完整跨簿(跨库)语句
            End If
        Next
        If z = 0 Then Exit Sub                                          '没有一个表格被选中就退出
    End With
   
       '用join函数 union all　各个分表语句，这里是合并
    Sql = Join(arra, " union all ") & " order by " & arr(0) & " "
   
       '这里是汇总,sql2已经求出来是 所有合计字段的合计 arr(0) 是每个表的第一个单元格 "姓名"，这里用 arr(0)是因为适合字段变化，比如＂产品名称＂
    If UserForm1.OptionButton2.Value = True Then Sql = "select " & sql2 & " from (" & Sql & ") group by " & arr(0) & " "
    With Sheets("sheet1")
        .Cells.ClearContents
        .Range("a1").Resize(1, UBound(arr) + 1) = d.Keys '下标为0,所以 +1
        .Range("a2").CopyFromRecordset cn.Execute(Sql)
    End With
    cn.Close
    Set cn = Nothing
End Sub


Private Sub CommandButton2_Click()
    Unload Me
End Sub

Private Sub UserForm_Activate()
    Application.ScreenUpdating = False
    DoEvents                                    '加载LISTVIEW内容时需要一定时间,先把表格和样式释放出来,加大等待容忍度
    p = ThisWorkbook.Path & "\"                 '路径
    f = Dir$(p & "*.xls")                        '判断工作簿是否存在
    Do While f <> ""                             '循环直到空
        If f <> ThisWorkbook.Name Then           '不汇总本工作簿
            Set wk = Workbooks.Open(p & f)       '打开工作簿
            'Set wk = GetObject(p & f)           '同上
            For Each sh In wk.Sheets             '工作簿中表格循环
                If sh.Range("a1") <> "" Then     '是否空表 可再联合 And Application.CountA(sh.Cells) > 1  进行判断
                    k = k + 1                    '计算所有表格数，可把工作簿和表格加载到LISTVIEW控件
                    r = sh.Range("iv1").End(xlToLeft).Column     '判断每个表格的最后一列
                    ar = sh.Range("a1").Resize(, r)              '每个表格第一行放到内存数组
                    cell = ""                                    '置放每个表格的第一行(标题信息)用,先置空
                    For i = 1 To r - 1                           'r-1 是为了把最后一个 '合计' 放到最后,所以暂时不加入字典
                        If Not d.exists(ar(1, i)) Then           '用第一个字典判断是否已存在
                            d(ar(1, i)) = s                      '加入字典
                            If i = 1 Then                        '判断是否第一个元素,是否需要用 sum(iif(len..........
                                sql2 = ar(1, i) & ","            'select 语句 每个字段的逗号也要加
                            Else
                                sql2 = sql2 & " sum(iif(len(" & ar(1, i) & ")=0,0," & ar(1, i) & ")),"   '如果字段长度为0,则0
                            End If
                        End If
                        cell = cell & ar(1, i) & ","              '第一行单元格循环合并,加逗号是为了查找时的唯一性
                    Next
                    d2(wk.Name & sh.Name) = cell & ","            '用第二个字典储存 不同工作簿不同工作表 第一行信息,不包括 '合计'
                    ListView1.ListItems.Add , , wk.Name           'LISTVIEW第一列加载工作簿名称,它将包含有内容的表格
                    ListView1.ListItems(k).SubItems(1) = sh.Name  'LISTVIEW第二列加载工作表名称,有内容的表格
                End If
            Next
            wk.Close False                                        '不保存关闭工作簿
        End If
        f = Dir$()                                                '空循环结束
    Loop
    d("合计") = s                                                 '加入第一个字典'合计'并且放到最后
    sql2 = sql2 & " sum(合计) "                                   'select 语句 添加一个 '合计'并且放到最后
    arr = d.Keys                                                  '转成数组
    Application.ScreenUpdating = True
End Sub

Private Sub UserForm_Initialize()
    Call Noclose(Me.Caption)                                       '窗体不显示关闭按钮
    OptionButton1.Value = True                                     '默认合并选项
    With Me.ListView1
        .ListItems.Clear                                            'LISTVIEW格式属性设置
        .ColumnHeaders.Clear
        .View = lvwReport
        .Gridlines = True
        .LabelEdit = lvwManual
        .CheckBoxes = True
        .ColumnHeaders.Add , , " 工作簿", 100
        .ColumnHeaders.Add , , "  表格", 100
    End With
End Sub

office2008

请先 引用 microsoft  scripting runtime

wenwen000424

谢谢，非常不错，有一定的通用性，现根据的表格中都有一个合计，如果去掉表格中的合计一项，请问怎样修改？

兰州人

深入研究这个程序。

linpansheng

office2008是高人，学习一下

he_xw

学习、学习

2288liu

.Range("a2").CopyFromRecordset cn.Execute(Sql)
为什么这句公式错误呢

dgbeyondma

学习中  谢了

ljx63426

学习中  谢了

goons

学习消化中