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

wenwen000424

谢谢，非常不错。

wenwen000424

能否自动生成数据有效性可以选择"√"或"×"的样子

zhaogang1960

Sub 自动生成第一行()
    Dim sh As Worksheet, arr(), m As Integer, lc As Integer
    lc = (Sheets.Count - 1) * 2
    For i = 1 To lc Step 2
        With Cells(1, i + 1).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:="√,×"
        End With
    Next
    ReDim arr(1 To lc)
    m = -1
    For Each sh In Sheets
        If sh.Name <> "汇总" Then
            m = m + 2
            arr(m) = sh.Name
            arr(m + 1) = "√"
        End If
    Next
    Rows(1).ClearContents
    Range("a1").Resize(1, m + 1) = arr
End Sub

wenwen000424

谢谢你不厌其烦的热心帮助。

office2008

ADO+SQL+字典+数组

Sub xxx()
    Dim cn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    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 <> "汇总" 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
                        sql1 = ar(1, i)
                        sql2 = sql1 & ","
                    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
    ReDim arra(1 To Sheets.Count - 1)
    z = 0
    For Each sh In Sheets
        If sh.Name <> "汇总" Then
            z = z + 1
            ss = ""
            For i = 1 To r
                ss = ss & sh.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 [" & sh.Name & "$] "
        End If
    Next
    Sql = Join(arra, " union ")                                                '这里是合并
    Sql = "select " & sql2 & " from (" & Sql & ") group by " & sql1 & ""       '这里是汇总
    '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

wenwen000424

谢谢，测试出现类型未定义错误，我是excel2003版。

office2008

哦,只要引用一下 或者
把下面两句去掉
  Dim cn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
改成
  set  cn =createobject("ADODB.Connection")   '这一句就可以了

wenwen000424

测试还有两个问题：（1）没有根据第1行的自由选择进行合并或汇总；（2）汇总没能错误，合并时出现错误。可能是我太莱，能否根据我提供的附件帮助做一个传上来，谢谢！

office2008

重新整理了一遍,两种方法都有

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 <> "汇总" 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)
                    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
    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-1-24 13:46 编辑 ]

wenwen000424

谢谢,非常好。很高兴一次收获了两种方式的编码。山菊花的处理方式也不错，不知能否将他的程序也完善一下。