帮修改SQL只合并包含导出这两个字符的工作表，每份工作表名称是XX导出XX

samia

Sub ADO法汇总()
    Dim Fso As Object, Folder As Object, arr$(), m&, cnn As Object, SQL$, i&
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Folder = Fso.GetFolder(ThisWorkbook.Path)
    Application.ScreenUpdating = False
    Call GetFiles(Folder, arr, m)
    Set cnn = CreateObject("adodb.connection")
    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & arr(1)
    ActiveSheet.UsedRange.Offset(1).ClearContents
    For i = 1 To m
        SQL = "select * from [Excel 12.0;Database=" & arr(i) & ";].[导出$]"
        Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    Next
    Set Folder = Nothing
    Set Fso = Nothing
    cnn.Close
    Set cnn = Nothing
    Set File = Nothing
    Set Fso = Nothing
    Application.ScreenUpdating = True
End Sub

Sub GetFiles(ByVal Folder As Object, arr$(), m&)
    Dim SubFolder As Object
    Dim File As Object
    If Folder.Path <> ThisWorkbook.Path Then
        For Each File In Folder.Files
            If File.Name Like "*.xlsm" Then
                m = m + 1
                ReDim Preserve arr(1 To m)
                arr(m) = File
            End If
        Next
    End If
    For Each SubFolder In Folder.SubFolders
        Call GetFiles(SubFolder, arr, m)
    Next
End Sub

xiangbaoan

Sub ADO法汇总()
  Dim Cat As Object, Tbl As Object, strCnn As String, t As String
  Set Cat = CreateObject("ADOX.Catalog")
  
  Dim Fso As Object, Folder As Object, arr$(), m&, Cnn As Object, SQL$, i&
  Set Fso = CreateObject("Scripting.FileSystemObject")
  Set Folder = Fso.GetFolder(ThisWorkbook.Path)
  Application.ScreenUpdating = False
  Call GetFiles(Folder, arr, m)
  Set Cnn = CreateObject("adodb.connection")
  
  strCnn = "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source="
  Cnn.Open strCnn & ThisWorkbook.FullName
  
  ActiveSheet.UsedRange.Offset(1).ClearContents
  For i = 1 To m
    Cat.ActiveConnection = strCnn & arr(i)
    For Each Tbl In Cat.Tables
      If Tbl.Type = "TABLE" Then
        t = Replace(Tbl.Name, "'", "")
        If Right(t, 1) = "$" Then
          If t Like "*导出*" Then
            SQL = "select * from [Excel 12.0;Database=" & arr(i) & ";].[" & t & "]"
            Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset Cnn.Execute(SQL)
          End If
        End If
      End If
    Next
  Next
  Set Cat = Nothing
  Set Folder = Nothing
  Set Fso = Nothing
  Cnn.Close
  Set Cnn = Nothing
  Set File = Nothing
  Set Fso = Nothing
  Application.ScreenUpdating = True
End Sub