CODEWITHSUNDEEP
vbaexcelconnection-stringadodb
Calico
Calico

Reputation: 416

ADODB Connection - Header text not extracted & read-only issue

I am delving into the world of VBA data connections, and would appreciate some assistance. The code below is what I have so far, but there are a couple of oddities I can't figure out. 

Sub sbADO()
    Dim sSQLQry As String
    Dim ReturnArray
    Dim Conn As New ADODB.Connection
    Dim mrs As New ADODB.Recordset
    Dim DBPath As String, sconnect As String

    DBPath = "C:\USERS\NAME\DOCUMENTS\VBA Work\Data Source.xlsx"
    sconnect = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & DBPath & ";HDR=Yes';"
    Conn.Open sconnect

    sSQLQry = "SELECT * From [Sheet1$]"
    mrs.Open sSQLQry, Conn
    Sheet3.Range("A1").CopyFromRecordset mrs
    mrs.Close
    Conn.Close
End Sub

This code works, however:

  1. The data pulled in doesn't include Row1 of the dataset (so the headers aren't pulled in)
  2. If the source workbook 'Data Source.xlsx' is open. The code will cause the workbook to open again but in read-only mode. Can this be avoided?
  3. Can the connection string be edited so that the source file is never locked out? ie. queried in Read-Only mode other users can open it whilst the query is being completed?

Any help is appreciated Thanks Caleeco

Upvotes: 0

Views: 1233

Answers (1)

user5326167
user5326167

Reputation:

Try this:

Sub sbADO()
  Dim sSQLQry As String
  Dim ReturnArray
  Dim Conn As New ADODB.Connection
  Dim mrs As New ADODB.Recordset
  Dim DBPath As String, sconnect As String,i as integer

  'DBPath = ThisWorkbook.FullName
  DBPath = "C:\USERS\NAME\DOCUMENTS\VBA Work\Data Source.xlsx"
  sconnect= "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=""" & _
     DBPath & """;Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX = 1"""

  Conn.Open sconnect

  sSQLQry = "SELECT * From [Sheet1$]"
  mrs.Open sSQLQry, Conn
  if rs.recordcount>0 then 
     rs.movefirst
     for i=0 to rs.fields.count-1
       'read here the headers and add them to your sheet in row 1
       Sheet3.Cells(1, i + 1) =rs.Fields(i).Name
     next
  end if
  Sheet3.Range("A2").CopyFromRecordset mrs
  mrs.Close
  Conn.Close
End Sub

Upvotes: 1

Related Questions