|
|
本帖最后由 zhaogang1960 于 2016-5-31 22:47 编辑
请参考：
Sub ADO法()
Dim cnn As Object, rs As Object, SQL$, Fso As Object, Folder As Object, arr$(), m&, i&, wb As Workbook
Application.ScreenUpdating = False
Set cnn = CreateObject("adodb.connection")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Folder = Fso.GetFolder(ThisWorkbook.Path & "\数据")
Call GetFiles(Folder, arr, m)
Set wb = Workbooks.Add(xlWBATWorksheet)
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=excel 12.0;Data Source=" & arr(1)
SQL = "select * from [Sheet1$]"
Set rs = cnn.Execute(SQL)
With wb.Sheets(1)
For i = 1 To rs.Fields.Count
.Cells(1, i) = rs.Fields(i - 1).Name
Next
.[a2].CopyFromRecordset rs
For i = 2 To m
SQL = "select * from [Excel 12.0;Database=" & arr(i) & "].[Sheet1$]"
.Range("a" & .Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
Next
End With
Application.DisplayAlerts = False
wb.SaveAs ThisWorkbook.Path & "\需要得到的结果\001 Personal Wash.xlsx"
wb.Close
Set Folder = Nothing
Set Fso = Nothing
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
Application.ScreenUpdating = True
MsgBox "ok"
End Sub
Sub GetFiles(ByVal Folder As Object, arr$(), m&)
Dim SubFolder As Object
Dim File As Object
For Each File In Folder.Files
If File.Name Like "*.xlsx" Then
m = m + 1
ReDim Preserve arr(1 To m)
arr(m) = File
End If
Next
For Each SubFolder In Folder.SubFolders
Call GetFiles(SubFolder, arr, m)
Next
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2016-5-31 16:38
楼主