Sub 指定表名提取成一工作薄()   \'字段必须要在第一列
  On Error Resume Next
    Dim Filename$, fn$, dq$, crr()
    Set cnn = CreateObject("ADODB.Connection")
    Dim arr, n&, i&, j&, s$
    Dim MyPath$, myFile$
    Dim rs As Object
    Set d = CreateObject("scripting.dictionary")
    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=\'excel 12.0\';data source=" & ThisWorkbook.FullName
   [a1:p65536].ClearContents
    MyPath = ThisWorkbook.Path & "\"
    myFile = Dir(MyPath & "*.xls*")
    n = CreateObject("Scripting.FileSystemObject").GetFolder(MyPath).Files.Count - 1    \'计算文件个数，减1不包括自身
    ReDim arr(1 To 1000, 1 To n)  \'定义arr,最大工作表数1000
    Do While myFile <> ""
        If myFile <> ThisWorkbook.Name Then  \'不等于本工作簿执行
            j = j + 1
            i = 1
            arr(1, j) = Left(myFile, InStrRev(myFile, ".") - 1)    \'去后辍
            Set cnn = CreateObject("ADODB.Connection")
            cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & MyPath & myFile
            Set rs = cnn.OpenSchema(20)   \'Set rs = cnn.OpenSchema(adSchemaTables)，创建数据表记录集
            Do Until rs.EOF
                If rs.Fields("TABLE_TYPE") = "TABLE" Then
                    i = i + 1
                    s = Replace(rs("TABLE_NAME").Value, "\'", "")              \'去除"’"(数字工作表）
                    If Right(s, 1) = "$" Then arr(i, j) = Left(s, Len(s) - 1)     \'去除$号
                End If
                rs.MoveNext
            Loop
        End If
        myFile = Dir
    Loop
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Range("A1").Resize(i, j) = arr    \'输出
    Rows("1:1").Delete
    bmc = ActiveSheet.Name
    brr = Worksheets(bmc).UsedRange
For Each cf In brr
   If cf <> "" Then
    d(cf) = ""
    End If
Next
Worksheets(bmc).UsedRange.Delete
Application.ScreenUpdating = True
[b3].Resize(d.Count, 1) = Application.Transpose(d.keys)
  [b2] = "所有的工作表名如下 请选择！"
    Set cnn = CreateObject("ADODB.Connection")
    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=\'excel 12.0\';data source=" & ThisWorkbook.FullName
Flag:    Set zzdm = Application.InputBox(prompt:="请在出现的表名称中选择 可以点选 或者全选：", Type:=8)
    Application.ScreenUpdating = False
    For Each Rng In zzdm  \'计算出所选单元格的个数
        If Rng <> "" Then
            a = a + 1
            ReDim Preserve crr(1 To a)
            crr(a) = Rng
        End If
    Next
    ll = UBound(crr)
  Columns(2).Delete
  For Each c In crr
   If c = "" Then GoTo 333
     zdm = c
     Filename = Dir(ThisWorkbook.Path & "\*.xls*")
    Do While Filename <> ""
        If Filename <> ThisWorkbook.Name Then
            fn = ThisWorkbook.Path & "\" & Filename
            Sql = "select * from [" & fn & "]." & "[" & zdm & "$" & "]"
            r = [a65535].End(3).Row + 1
            Cells(r, 1).CopyFromRecordset cnn.Execute(Sql)
            r2 = [a65535].End(3).Row
            yy = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
        If r2 > 1 Then
         If jj = 0 Then
          Set rs = cnn.Execute(Sql)
          For i = 0 To yy - 1 \'逐个字段
          Cells(1, i + 1) = rs.Fields(i).Name \'取字段名
          jj = jj + 1
         Next i
     End If
    End If
End If
        Filename = Dir
    Loop
   
    ActiveSheet.Name = zdm
    ll1 = ll1 + 1
    If ll1 < ll Then
    ThisWorkbook.Sheets.Add After:=Worksheets(zdm)
    End If
    jj = 0
Next c
333:
    cnn.Close: Set cnn = Nothing
     Application.ScreenUpdating = True
     MsgBox "提取完毕！"
End Sub