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
