Consolidate data from closed workbooks adodb approach - excel

Question

I have found a code and modified to suit my files. The code is supposed to loop through closed workbooks (7 files) and import specific columns (myHeading) to ThisWorkbook
Sub Consolidate()
Dim a, ws As Worksheet, myDir As String, myHeading As String, sFile As String, cn As Object, rs As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Folder"
.InitialFileName = ThisWorkbook.Path & "\"
If .Show Then myDir = .SelectedItems(1) & "\"
End With
If myDir = "" Then Exit Sub
Set ws = ThisWorkbook.Worksheets("Sheet1")
a = Array("Accrued Date", "Description", "Amount Accrued (LC)", "Product", "Account Description", "Product Charge Code", "Country")
Application.ScreenUpdating = False
With ws
.Range("A1").Resize(, UBound(a) + 1).Value = a
With .Cells(1).CurrentRegion
myHeading = "`" & Join(.Parent.Evaluate(.Rows(1).Address & "&"""""), "`, `") & "`"
.Offset(1).ClearContents
End With
End With
sFile = Dir(myDir & "*.xlsx")
Do While sFile <> ""
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
With cn
.Provider = "Microsoft.Ace.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;"
.Open myDir & sFile
End With
rs.Open "Select " & myHeading & " From `MyReport$`;", cn
ws.Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset rs
rs.Close: cn.Close
Set cn = Nothing: Set rs = Nothing
sFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
The code takes too long time (about 5 minutes) although the files are only 7 and I have used ADODB approach which I know is more faster than opening the excel files directly.
Any ideas how to make it faster and what may obstacles the code and make it slow?

Answer 1

Can you try this (I couldn't test the code):
EDIT:
Commands can only be used if connected to an actual Database.
Sub Consolidate()
Dim a, ws As Worksheet, myDir As String, myHeading As String, sFile As String, cn As Object, rs As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Folder"
.InitialFileName = ThisWorkbook.Path & "\"
If .Show Then myDir = .SelectedItems(1) & "\"
End With
If myDir = "" Then Exit Sub
Set ws = ThisWorkbook.Worksheets("Sheet1")
a = Array("Accrued Date", "Description", "Amount Accrued (LC)", "Product", "Account Description", "Product Charge Code", "Country")
Application.ScreenUpdating = False
With ws
.Range("A1").Resize(, UBound(a) + 1).Value = a
With .Cells(1).CurrentRegion
myHeading = "`" & Join(.Parent.Evaluate(.Rows(1).Address & "&"""""), "`, `") & "`"
.Offset(1).ClearContents
End With
End With
sFile = Dir(myDir & "*.xlsx")
Set cn = CreateObject("ADODB.Connection")
With cn
.Open "Provider=Microsoft.Ace.OLEDB.12.0;Persist Security Info=False;"
End With
Do While sFile <> ""
Set rs = CreateObject("ADODB.Recordset")
rs.Open = "Select " & myHeading & " From [Excel 12.0 Xml; HDR = Yes;Database=" & myDir & sFile & "].[" & "MyReport$];"
ws.Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset rs
Set rs = Nothing
sFile = Dir
Loop
cn.Close: Set cn = Nothing
Application.ScreenUpdating = True
End Sub