[已解决]灵活的多工作表合并或汇总

山菊花

原帖由 蓝桥玄霜 于 2009-1-27 13:26 发表
其实每个人的表格千变万化，包括不同的表头、不同的位置、想要汇总的不同的区域、不同的汇总方法等等，想要一网打尽几乎是不可能的。还是只能针对某几种特定的表格来解决的。

正确。VBA的特点是量身定做，根据不同的情况编写的同的程序。

fyb0087

但可提供用户灵活选择区域汇总或根据字段进行灵活汇总

fdd

学习。回复楼上：如果真是那样，那不就象EXCEL软件一样了吗?那就是大程序了！

office2008

一直没空直到今天才有空,仔细检查了一遍,发现几处错误,用兰色更正了一下. 其中有个错误是添加空表后,d(ar(1, UBound(ar, 2))) = s就会出现UBound(ar, 2)=0 的 错误,这样肯定会引起错误,很可能就是只观看兄弟指出的错误,谢谢他的提醒,已重新更新请再试.

Private Sub CommandButton1_Click()
    Dim arra()
    Set cn = CreateObject("ADODB.Connection")
    cn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
    Set d = CreateObject("scripting.dictionary")

    For Each sh In Sheets
        If sh.Name <> "汇总" And sh.Range("a1") <> "" Then
            r = sh.Range("iv1").End(xlToLeft).Column
            ar = sh.Range("a1").Resize(, r)
            For i = 1 To r - 1
                If Not d.exists(ar(1, i)) Then
                    d(ar(1, i)) = s
                    If i = 1 Then
                        sql2 = ar(1, i) & ","
                    Else
                        sql2 = sql2 & " sum(iif(len(" & ar(1, i) & ")=0,0," & ar(1, i) & ")),"
                    End If
                End If
            Next
        End If
    Next
   
    d(ar(1, UBound(ar, 2))) = s
    sql2 = sql2 & " sum( " & ar(1, UBound(ar, 2)) & ") "
    arr = d.Keys    ': d.RemoveAll
    z = 0
    With UserForm2.ListView1
        For j = 1 To .ListItems.Count
            If .ListItems(j).Checked = True Then
                z = z + 1
                ReDim Preserve arra(1 To z)
                With Sheets(.ListItems(j).Text)
                   r = .Range("iv1").End(xlToLeft).Column                  
                    ss = ""
                    For i = 1 To r
                        ss = ss & .Cells(1, i) & ","
                    Next
                    For i = 0 To UBound(arr)
                        If InStr(ss, arr(i)) Then
                            arra(z) = arra(z) & arr(i) & ","
                        Else
                            arra(z) = arra(z) & "'' as " & arr(i) & "" & ","
                        End If
                    Next
                    arra(z) = " select " & Left(arra(z), Len(arra(z)) - 1) & " from [" & .Name & "$] "
                End With
            End If
        Next
        If z = 0 Then Exit Sub

    End With
    Sql = Join(arra, " union ")                                                '这里是合并
    If UserForm2.OptionButton2.Value = True Then Sql = "select " & sql2 & " from (" & Sql & ") group by " & ar(1, 1) & ""    '这里是汇总
    'MsgBox Sql
    With Sheets("汇总")
        .Cells.ClearContents
        .Range("a1").Resize(1, UBound(arr) + 1) = d.Keys
        .Range("a2").CopyFromRecordset cn.Execute(Sql)
    End With
End Sub

Private Sub CommandButton2_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    Call Noclose(Me.Caption)
    OptionButton1.Value = True
    With Me.ListView1
        .ListItems.Clear
        .ColumnHeaders.Clear
        .View = lvwReport
        .FullRowSelect = True
        .Gridlines = True
        .MultiSelect = True
        .CheckBoxes = True
        .ColumnHeaders.Add , , "项目", 60
        For i = 1 To ThisWorkbook.Sheets.Count
            If Sheets(i).Name <> "汇总" Then .ListItems.Add , , Sheets(i).Name
        Next i
        '.SelectedItem.Selected = False                 '不选中
    End With
End Sub


附件已更新！

[ 本帖最后由 office2008 于 2009-2-3 11:22 编辑 ]

jaxzhu

谢谢，这个思路好

fyb0087

请教高手OFFICE2008，如果我的表格位置在第六行和B列位置，如何修改以上代码。（请高手详细写一个各个语名的注释。多谢了

ljx63426

OFFICE2008,您真是高手,一出手就解决大问题,您是否可以抽点时间,将您编的代码注释一下,让我等菜鸟好好学习,运用到实际工作之中,就象楼上一样,表格位置和数据位置改变了,就不知修改代码了,仍然无法运用自如.请楼上不要见怪,我和你一样,也是不知修改代码,呵呵!!!

fyb0087

太实用了，请高手给个注释，初学者方便根据自己表格改变一下，灵活运用。多谢了

xpm130

原帖由 ljx63426 于 2009-2-3 23:51 发表
OFFICE2008,您真是高手,一出手就解决大问题,您是否可以抽点时间,将您编的代码注释一下,让我等菜鸟好好学习,运用到实际工作之中,就象楼上一样,表格位置和数据位置改变了,就不知修改代码了,仍然无法运用自如.请楼上不要 ...

是啊,我等看不懂代码,也就谈不上应用了,像我的表格样式如下:

工号与账号是不需要汇总的,就不知该怎么变通了!

fyb0087

请高手OFFICE2008支持，多作贡献。带动大家的积极性。