Collect data from specific column from closed workbooks using ADO

[YasserKhalil]

Hello everyone
I have different excel files and there is a specific column which I need to collect the data from. The column may have different names "Reference","Ref No","Number" ... and the column is not fixed (I mean sometimes at column A or column C or column T)
Is there a way using ADO to deal such case or I will have to use the usual approach of dealing with the closed workbooks?

* The closed workbooks may have more than a sheet and all the sheets needed to be dealt with.

[HansV]

In your previous thread, I have shown you how to use ADO to get a list of worksheets in a workbook and how to get a list of field names (column headers) in a worksheet.
You should be able to use that to do what you want.

[YasserKhalil]

I can't get the whole issue well. So I prefer to take it step by step
I have to deal with just one excel file then looping later.
Can you show me how to deal with just one file and get the data from it and I will study it well..?

[YasserKhalil]

This deals with how to get the worksheets

Code: Select all

Sub Test()
    Dim arIn1, arIn2, arOut, s, ws As Worksheet, rs As Object, sq As String, pt As String, colNames As String, iCol As Integer, m As Long, r As Long, c As Long
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select The Data File"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show <> -1 Then Exit Sub
        pt = .SelectedItems(1)
    End With
    Set cn = CreateObject("ADODB.Connection")
    cn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & pt & "';" & "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
    Set rs = cn.OpenSchema(20)
    Do While Not rs.EOF
        sName = rs.Fields("Table_Name")
        If Right(sName, 14) <> "FilterDatabase" Then
            sName = Left(sName, Len(sName) - 1)
            Debug.Print sName
            With Worksheets(sName)
                'give me example how to deal with the sheet in that case
            End With
        End If
        rs.MoveNext
    Loop
    rs.Close
End Sub

but I am confused about how to deal with the worksheet in the closed workbook. How to match the headers from first row and then with the found header to get the data and populate the result into the workbook that has the code?

[HansV]

You can't use With Worksheets(sName) in ADO - that is Excel VBA.
Just study the code you already have - everything you need is in there.

[YasserKhalil]

Thanks a lot
I will take the issue from the scratch so as to be able to get the whole process
Now I have this code that imports the data from Sheet1 from Sample workbook

Code: Select all

Sub ImportFromClosedWorkbook()
    Dim cn As ADODB.Connection, rs As ADODB.Recordset, sFile As String, shName As String, strSQL As String
    sFile = ThisWorkbook.Path & "\Sample.xlsx"
    shName = "Sheet1"
    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;"";"
    strSQL = "SELECT * FROM [" & shName & "$]"
    Set rs = New ADODB.Recordset
    Set rs = cn.Execute(strSQL)
    Range("A1").CopyFromRecordset rs
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
End Sub

Based on this code I will try to add myself the needed parts but of course I need your guidance.
Next step for me is to loop throgh 1d array that has possible headers and match if found one of these headers according to the closed workbook.

[YasserKhalil]

This is my try till now. Not clean as I am trying to get how the process go on

Code: Select all

Sub ImportFromClosedWorkbook()
    Dim e, 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"
    shName = "Sheet1"
    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 rs = cn.OpenSchema(20)
    Do While Not rs.EOF
        sName = rs.Fields("Table_Name")
        If Right(sName, 14) <> "FilterDatabase" Then
            sName = Left(sName, Len(sName) - 1)
            Debug.Print sName
            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
                Debug.Print rsHeaders.Fields(iCol).Name
                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
                Debug.Print e
                'here I am stuck of how to get the data from the found column
            End If
        
            rs.Close
        End If
        rs.MoveNext
    Loop
    rs.Close

    '------------------
    '    strSQL = "SELECT * FROM [" & shName & "$]"
    '    Set rs = New ADODB.Recordset
    '    Set rs = cn.Execute(strSQL)
    '    Range("A1").CopyFromRecordset rs
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
End Sub

'here I am stuck of how to get the data from the found column

[HansV]

I'm confused: you use sName and shName. Which is correct?

[YasserKhalil]

shName was for the fixed and known sheet. It is not important now as I am looping through the worksheets as you showed me
And inside each loop I loop for the headers and inside the loop of header I put another loop searching for the specific headers and if found then we found the header and the column that we need to grab.

[HansV]

You need a SQL string such as

strSQL = "SELECT [" & e & "] FROM [" & sName & "]"

[YasserKhalil]

This is the last code but I got error with the part of importing the data

Code: Select all

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"
    'shName = "Sheet1"
    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
    Set rs = cn.OpenSchema(20)
    Do While Not rs.EOF
        sName = rs.Fields("Table_Name")
        If Right(sName, 14) <> "FilterDatabase" Then
            sName = Left(sName, Len(sName) - 1)
            Debug.Print sName
            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
                Debug.Print rsHeaders.Fields(iCol).Name
                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
                'Debug.Print e
            strSQL = "SELECT [" & e & "] FROM [" & sName & "]"
            Set rs = New ADODB.Recordset
            Set rs = cn.Execute(strSQL)
            ws.Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row).CopyFromRecordset rs
                'here I am stuck of how to get the data from the found column
            End If
        
            rs.Close
        End If
        rs.MoveNext
    Loop
    rs.Close

    '------------------
    '    strSQL = "SELECT * FROM [" & shName & "$]"
    '    Set rs = New ADODB.Recordset
    '    Set rs = cn.Execute(strSQL)
    '    Range("A1").CopyFromRecordset rs
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
End Sub

[YasserKhalil]

After a lot of trial and failure I could solve it as for one file .. But I think code can be more compact (Are there any ideas reagrds the existing code?)

Code: Select all

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"
    'shName = "Sheet1"
    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
    Set rs = cn.OpenSchema(20)
    Do While Not rs.EOF
        sName = rs.Fields("Table_Name")
        If Right(sName, 14) <> "FilterDatabase" Then
            sName = Left(sName, Len(sName) - 1)
            'Debug.Print sName
            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
                'Debug.Print rsHeaders.Fields(iCol).Name
                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
                'Debug.Print e
            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
                'here I am stuck of how to get the data from the found column
            End If
        
            'rs.Close
        End If
        rs.MoveNext
    Loop
    'rs.Close

    '------------------
    '    strSQL = "SELECT * FROM [" & shName & "$]"
    '    Set rs = New ADODB.Recordset
    '    Set rs = cn.Execute(strSQL)
    '    Range("A1").CopyFromRecordset rs
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
End Sub

Also I noticed that it works with the worksheets in the sample workbook but in reverse order. I mean the code grabs the data from "New" sheet first then from "Sheet1". Is there a way to control that as I need the data by the sequence of the worksheets?

[HansV]

Wouldn't it be easier to open the workbook in Excel and to inspect the worksheets?

[YasserKhalil]

I need to learn new skills. You are right.
Isn't that approach more efficient and faster?
* if it is impossible to deal with the worksheets in order, no problem.
Can you help me convert this to public procedure as this will be executed through many files?

[YasserKhalil]

This is the last code that I could through it get the sheets in order of the tabs

Code: Select all

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

Can you please help me adjust that to be a public procedure so as to be able to apply to multiple workbooks?

[HansV]

It'd be something like

Code: Select all

Sub ImportFromClosedWorkbook(sName As String)

Remove the declararion of sName from the code, as well as the line

Code: Select all

    sFile = ThisWorkbook.Path & "\Sample.xlsx"

You can then call ImportFromClosedWorkbook with the path+filename of any workbook.

[YasserKhalil]

Thank you very much.
In fact, I want to adjust the objects of connection and recordset and release the objects properly to free memory correctly..
Can you help me at this point only?

[HansV]

You already have lines to do that.

Why do you have both DAO and ADODB objects in your code?

[YasserKhalil]

DAO for getting the worksheets in the order of tabs (the point we discuss before) ..

[HansV]

If you need DAO, I'd use the DAO object db to open the recordsets as well, and ditch the ADODB connection.