VBA Macro to open multiple Access database tables from a list and and copy headers back into excel

[kthorson16]

I am trying to modify the below code to loop thru a list of path location where databases are located: rDirList = Sheets("DRG").Range("I6:I99") and the paste the header table results on the row below. Anyone have any suggestions on how to get this to work?
Code:
Sub OpenTable()
Dim cn As Object
Dim rs As Object
Dim i As Integer
Dim Conn As String
Dim strTable As String
Dim Coll As New Collection


Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")


strTable = "Rx"
Conn = "Provider = Microsoft.ACE.OLEDB.12.0; Data Source=" & _
"H:\VBADatabase\Test_PR_YTD_thru_JAN_2016.mdb;"

cn.Open Conn
rs.Open Source:=strTable, ActiveConnection:=cn, CursorType:=1, LockType:=3


For i = 0 To rs.Fields.Count - 1
'get field / column name:
Coll.Add rs.Fields(i).Name
Next i


'send names to row 1 of active worksheet
For i = 1 To Coll.Count
Cells(1, i) = Coll(i)

 

[Sektor]

Sub OpenTable()


    Dim rs As Object
    Dim i%, x%
    Dim Conn$, strTable$
    Dim rngDbPath As Range
    
    Set rs = CreateObject("ADODB.Recordset")
    
    For Each rngDbPath In Sheets("DRG").Range("I6:I99")
        
        strTable = "Rx"
        Conn = "Provider = Microsoft.ACE.OLEDB.12.0; Data Source=" & rngDbPath.Value
        
        rs.Open Source:=strTable, ActiveConnection:=Conn, CursorType:=1, LockType:=3
        
        x = x + 1
        For i = 0 To rs.Fields.Count - 1
            Cells(x, 1).Offset(i).Value = rs.Fields(i).Name
        Next i
        
    Next


End Sub

 

[kthorson16]

I have actually updated my code to paste the data on a specific sheet and column, I am trying to incorporate what you did to have to go on the designate sheet but no matter what I put it is still adding it to my DRG tab, here is my updated code:

Sub OpenTable()
Dim cn As Object
Dim rs As Object
Dim i As Integer
Dim Conn As String
Dim strTable As String
Dim Coll As New Collection
Dim rDirList As Range

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
Set rDirList = Sheets("DRG").Range("J6")

strTable = "Rx"
Conn = "Provider = Microsoft.ACE.OLEDB.12.0; Data Source=" & _
"H:\VBADatabase\PROGRESSIVE_PR_YTD_thru_JAN_2016.mdb;"

cn.Open Conn
rs.Open Source:=strTable, ActiveConnection:=cn, CursorType:=1, LockType:=3


For i = 0 To rs.Fields.Count - 1
'get field / column name:
Coll.Add rs.Fields(i).Name
Next i


'send names to row 7 of active worksheet
For i = 1 To Coll.Count
Sheet = "COSMOS New Deals Database"
Cells(25, i) = Coll(i)
Next i
End Sub