帮忙修改下程序及写下程序，非常感谢

可爱天使

两表合并代码，但表头有很多中文表题时运行不起来
Private Sub CommandButton1_Click()
    Dim i%, c%, n%
    Dim SQL$, myField$
    Dim Dkey
    Dim Arr()
    Dim Cnn As Object
    Dim Rst As Object
    Dim Dic1 As Object
    Dim Dic2 As Object
    Dim regEx As Object
    Dim Sh As Worksheet
   
    Application.ScreenUpdating = False
   
    '确定完整的表头
    Set Dic1 = CreateObject("Scripting.Dictionary")
    Set Dic2 = CreateObject("Scripting.Dictionary")
   
    For Each Sh In Sheets
        If Not Sh.Name Like "*汇总表*" Then
            c = Sh.Range("IV1").End(xlToLeft).Column
            Arr = Sh.Range("A1").Resize(1, c).Value
            For i = 1 To UBound(Arr, 2)
                Dic1(Sh.Name) = Dic1(Sh.Name) & Arr(1, i)
                Dic2(Arr(1, i)) = ""
            Next
        End If
    Next
      
    myField = Join(Dic2.Keys, ",")          '完整表头，用逗号连接
   
    '设置正则表达式基本参数
    Set regEx = CreateObject("VBScript.RegExp")
    With regEx
        .Global = True
        .IgnoreCase = False
    End With
   
    Set Cnn = CreateObject("ADODB.Connection")
    Set Rst = CreateObject("ADODB.Recordset")
    Cnn.Open "Provider=Microsoft.ACE.OleDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=1';Data Source=" & ThisWorkbook.FullName
   
    n = 1
    Columns("J:IV").ClearContents
    Range("J1").Resize(1, Dic2.Count).Value = Dic2.Keys         '完整表头
   
    For Each Dkey In Dic1.Keys
        r = Sheets(Dkey).Range("A65536").End(xlUp).Row
        regEx.Pattern = "[^" & Dic1(Dkey) & ",]"
        SQL = regEx.Replace(myField, "''")
        SQL = "SELECT " & SQL & " FROM [" & Dkey & "$" & Sheets(Dkey).UsedRange.Address(0, 0) & "]"
        Rst.Open SQL, Cnn, 1, 3
        Range("J1").Offset(n, 0).CopyFromRecordset Rst
        n = n + Rst.RecordCount
        Rst.Close
    Next
    Cnn.Close
   
    Set Dic1 = Nothing
    Set Dic2 = Nothing
    Set regEx = Nothing
    Set Rst = Nothing
    Set Cnn = Nothing
   
    Application.ScreenUpdating = True
End Sub

可爱天使

压缩文件发不上去，奇怪了

可爱天使

不知道哪里出了问题

可爱天使

帮忙修改下

魂断蓝桥

不知理解的对不对，表头重复的才union all 吗

Option Explicit

Sub a()
Dim d, j%, arr, sh As Worksheet, m%, brr(), r%
Set d = CreateObject("Scripting.Dictionary")
For Each sh In Sheets
    If sh.Name <> "汇总表" Then
        m = m + 1
        arr = sh.[a1].CurrentRegion
       ReDim Preserve brr(1 To m)
       brr(m) = "[" & sh.Name & "$a1:z" & UBound(arr) & "]"
        For j = 1 To UBound(arr, 2)
                d(arr(1, j)) = d(arr(1, j)) + 1
        Next
    End If
Next
Dim sql$, k, s$
[a:Z] = ""
m = 0
For j = 1 To UBound(brr)
    For Each k In d.Keys
        If d(k) = UBound(brr) Then
            If j = 1 Then
                m = m + 1
                Cells(1, m) = k
            End If
            s = s & k & ","
        End If
    Next
        s = Left(s, Len(s) - 1)
        sql = sql & "select " & s & " from " & brr(j) & " UNION ALL "
        s = ""
Next
sql = Left(sql, Len(sql) - 11)
Dim cnn
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.OleDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=1';Data Source=" & ThisWorkbook.FullName
[a2].CopyFromRecordset cnn.Execute(sql)
Set d = Nothing
Set cnn = Nothing
End Sub