Import from closed workbooks using ADODB

Question

After so many hours in that field, I could be able to get data from all the worksheets in closed workbook and could get data from specific columns using ADODB. @Siddharth Rout helped me to be able to get the sheet names in the order of tab. The following code works fine for only one closed workbook. But in fact I am trying to do the same and get all the data from the specific column (Reference - Ref No - Number ..) from several workbooks

Sub ImportFromClosedWorkbook()
    Dim e, ws As Worksheet, cn As ADODB.Connection, rs As ADODB.Recordset, rsHeaders As ADODB.Recordset, b As Boolean, sFile As String, shName As String, strSQL As String, iCol As Long
    sFile = ThisWorkbook.Path & "\Sample.xlsx"
    Dim con As Object
    Set con = CreateObject("DAO.DBEngine.120")
    Dim rsData As ADODB.Recordset
    Set cn = New ADODB.Connection
    cn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & sFile & "';" & "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
    Set ws = ThisWorkbook.ActiveSheet
    Dim db As Object, i As Long
    Set db = con.OpenDatabase(sFile, False, True, "Excel 12.0 XMl;")
    For i = 0 To db.TableDefs.Count - 1
        sName = db.TableDefs(i).Name
        b = False
        strSQL = "SELECT * FROM [" & sName & "]"
        Set rsHeaders = New ADODB.Recordset
        rsHeaders.Open Source:=strSQL, ActiveConnection:=cn, Options:=1
        For iCol = 0 To rsHeaders.Fields.Count - 1
            For Each e In Array("Ref No", "Reference", "Number")
                If e = rsHeaders.Fields(iCol).Name Then
                    b = True: Exit For
                End If
            Next e
            If b Then Exit For
        Next iCol
        If b Then
            strSQL = "SELECT [" & e & "] FROM [" & sName & "]"
            Set rsData = New ADODB.Recordset
            Set rsData = cn.Execute(strSQL)
            ws.Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset rsData
            rsData.Close
        End If
    Next i
    db.Close: Set db = Nothing
    Set con = Nothing
    cn.Close: Set cn = Nothing
End Sub

Is it suitable to build a public procedure or what's the best approach in that case and how can I release the objects in correct way?

Tim Williams · Accepted Answer · 2020-09-14T06:42:31.397

I would break out your code even more - there are distinct activities which could be factored out into reusable methods.

FYI your tableDefs objects already contains the field names, so there's no need to separately query for those.

Eg:

Sub ImportFromClosedWorkbook()
    Dim sFile As String, sheetName As String, colName As String, rs As ADODB.Recordset
    Dim cols As Collection, col
    
    sFile = ThisWorkbook.FullName
    
    Set cols = FindColumns(sFile, Array("Ref", "Reference", "RefNo"))
    'loop found columns
    For Each col In cols
        
        sheetName = col(0)
        colName = col(1)
        Debug.Print "##", sheetName, colName
        Set rs = WorkBookQuery(sFile, "Select [" & colName & "] from [" & sheetName & "]")
        If Not rs.EOF Then
         '   ActiveSheet.Cells(Rows.Count, "A").End(xlUp).CopyFromRecordset rs
        End If
    
    Next col

End Sub

'given a workbook path, find all column headings matching andname in arrNames
'returns a collections of [sheetName, columnName] arrays
Function FindColumns(wbFullPath As String, arrNames) As Collection
    
    Dim tabledefs As Object, td As Object, f As Object, rv As New Collection
    
    Set tabledefs = CreateObject("DAO.DBEngine.120") _
                     .OpenDatabase(wbFullPath, False, True, "Excel 12.0 XMl;").tabledefs
    
    For Each td In tabledefs
        For Each f In td.Fields
            'Debug.Print td.Name, f.Name
            If Not IsError(Application.Match(f.Name, arrNames, 0)) Then
                rv.Add Array(td.Name, f.Name)
            End If
        Next f
    Next td
    Set FindColumns = rv
End Function

'run a SQL query against a workbook
Function WorkBookQuery(wbFullPath As String, SQL As String) As ADODB.Recordset
    Dim rs As ADODB.Recordset
    With New ADODB.Connection
        .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & wbFullPath & "';" & _
               "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
        Set WorkBookQuery = .Execute(SQL, Options:=1)
    End With
End Function

That's really wonderful. Thanks a lot. In the Sample workbook there are two sheets and I noticed your code is getting from just one sheet. How can this be fixed to be able to deal with all the worksheets? — YasserKhalil, Sep 13 '20 at 19:56
See my edits above - for some reason I had it in my head there was only one matching column per file... — Tim Williams, Sep 14 '20 at 06:43
Really amazing. Thank you very much for sharing such a magic solution. — YasserKhalil, Sep 14 '20 at 08:27

score 1 · Answer 2 · answered Sep 13 '20 at 14:42

There seems to be a logical error in the process of cycling through the fields. It would be nice to use a user-defined function that checks if the field name exists.

Sub ImportFromClosedWorkbook()
    Dim e, ws As Worksheet, cn As ADODB.Connection, rs As ADODB.Recordset, rsHeaders As ADODB.Recordset, b As Boolean, sFile As String, shName As String, strSQL As String, iCol As Long
    Dim sField As String
    
    sFile = ThisWorkbook.Path & "\Sample.xlsx"
    Dim con As Object
    Set con = CreateObject("DAO.DBEngine.120")
    Dim rsData As ADODB.Recordset
    Set cn = New ADODB.Connection
    cn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & sFile & "';" & "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
    Set ws = ThisWorkbook.ActiveSheet
    Dim db As Object, i As Long
    Set db = con.OpenDatabase(sFile, False, True, "Excel 12.0 XMl;")
    For i = 0 To db.TableDefs.Count - 1
        sName = db.TableDefs(i).Name
        b = False
        strSQL = "SELECT * FROM [" & sName & "]"
        Set rsHeaders = New ADODB.Recordset
        rsHeaders.Open Source:=strSQL, ActiveConnection:=cn, Options:=1
        
        For iCol = 0 To rsHeaders.Fields.Count - 1
'            For Each e In Array("Ref No", "Reference", "Number")
'                If e = rsHeaders.Fields(iCol).Name Then
'                    b = True: Exit For
'                End If
'            Next e
'            If b Then Exit For
'        Next iCol
'        If b Then
            sField = rsHeaders.Fields(iCol).Name
            If isField(sField) Then
                strSQL = "SELECT [" & sField & "] FROM [" & sName & "]"
                Set rsData = New ADODB.Recordset
                Set rsData = cn.Execute(strSQL)
                ws.Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset rsData
                rsData.Close
            End If
        Next iCol
    Next i
    db.Close: Set db = Nothing
    Set con = Nothing
    cn.Close: Set cn = Nothing
End Sub
Function isField(sField As String) As Boolean
    Dim vName As Variant, e As Variant
    vName = Array("Ref No", "Reference", "Number")
    For Each e In vName
        If e = sField Then
            isField = True
            Exit Function
        End If
    Next e
End Function

score -1 · Answer 3 · answered Sep 13 '20 at 10:55

-1

If all the files have the same structure and are in a folder, you could use the FileSystemObject reference as below:

"https://stackoverflow.com/questions/10380312/loop-through-files-in-a-folder-using-vba"

and you could run the existing code in a loop in the file system code, hope that works

answered Sep 13 '20 at 10:55

Radhish Thekkute

87
3

Thanks a lot. In fact, I know how to loop through the excel files. What I am facing a problem is dealing with the objects and will it be suitable to use public procedure or better to implement the loop for excel files into the existing code? – YasserKhalil Sep 13 '20 at 10:59
1

I think you can loop your existing code inside the code which loops through excel files in a folder – Radhish Thekkute Sep 13 '20 at 14:41

Import from closed workbooks using ADODB

3 Answers3