Sub 多工作簿工作表汇总()
Dim Cnn As Object, Rst As Object, Rs As Object, FilePath$, FullName$, FullPath$, Sql$, Sht_Name$, i&
Set Cnn = CreateObject("ADODB.Connection")
Set Rst = CreateObject("ADODB.Recordset")
FilePath = ThisWorkbook.Path
FullName = Dir(FilePath & "\*.xls*")
Do While FullName <> ""
If FullName <> ThisWorkbook.Name Then
FullPath = FilePath & "\" & FullName
Cnn.Open "Provider=Microsoft.Ace.Oledb.12.0;Extended Properties=Excel 12.0;Data Source=" & FullPath
Set Rst = Cnn.OpenSchema(20)
Do Until Rst.EOF
Sht_Name = Rst("TABLE_NAME").Value
If Sql = "" Then
Sql = "select * from [" & FullPath & "].[" & Sht_Name & "]"
Else
Sql = Sql & " Union all select * from [" & FullPath & "].[" & Sht_Name & "]"
End If
Rst.MoveNext
Loop
Rst.Close
Cnn.Close
End If
FullName = Dir
Loop
Cnn.Open "Provider=Microsoft.Ace.Oledb.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
Set Rs = Cnn.Execute(Sql)
For i = 0 To Rs.Fields.Count - 1
Cells(1, i + 1).Value = Rs.Fields(i).Name
Next i
[a2].CopyFromRecordset Rs
Cnn.Close
Set Rs = Nothing
Set Rst = Nothing
Set Cnn = Nothing
End Sub
网友评论