提取多个excel数据到新表

zhouzihan

新建文件夹.7z (16.57 KB, 下载次数: 22)

2020-6-27 12:27 上传

点击文件名下载附件
提取多个excel数据到新表

xiangbaoan

Option Explicit
Sub test() '不要隐藏工作簿
Dim Cn As Object, Rs As Object, d As Object, p$, f$, Sq$, i&, j&, k&
Cells.ClearContents
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set Cn = CreateObject("ADODB.Connection")
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls*")
Do While f <> ""
  If f <> ThisWorkbook.Name Then
    k = k + 1
    Sq = "SELECT * FROM [Excel 12.0;Database=" & p & f & "].[$A1:R] WHERE [PONumber] IS NOT NULL"
    d(Sq) = ""
    If k Mod 49 = 0 Then
      i = i + 1
      Sq = Join(d.Keys, " UNION ALL ")
      d.RemoveAll
      Set Rs = Cn.Execute(Sq)
      If i = 1 Then
        For j = 0 To Rs.Fields.Count - 1
          Range("A1").Offset(0, j) = Rs.Fields(j).Name
        Next
      End If
      Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset Rs
    End If
  End If
  f = Dir
Loop
If d.Count > 0 Then
  Sq = Join(d.Keys, " UNION ALL ")
  Set Rs = Cn.Execute(Sq)
  If i = 0 Then
    For j = 0 To Rs.Fields.Count - 1
      Range("A1").Offset(0, j) = Rs.Fields(j).Name
    Next
  End If
  Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset Rs
End If
Cn.Close
Set Cn = Nothing
Set Rs = Nothing
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!", 64
End Sub

xiangbaoan

………………

zhouzihan