CODEWITHSUNDEEP
excelvba
YasserKhalil
YasserKhalil

Reputation: 9538

Import from closed workbooks using ADODB

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?

Upvotes: 0

Views: 277

Answers (3)

Tim Williams
Tim Williams

Reputation: 166331

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

Upvotes: 2

Dy.Lee
Dy.Lee

Reputation: 7567

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

Upvotes: 1

Radhish Thekkute
Radhish Thekkute

Reputation: 87

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

Upvotes: -1

Related Questions