方法之將不同excel里面相同名稱的工作表合並

#########使用excel2016##########

1、將待合並的多個excel放在一個文件夾中；

2、’在該文件夾下新建一個空白的excel；

3、打開新建的excel，在表名Sheet1上右擊，點擊查看代碼；

4、在跳出的窗口中輸入一下代碼：

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

5、點擊運行-運行子過程/用戶窗體，然后根據跳出的窗口操作，最好保存為啟用宏的工作簿即可。