I'm trying to write some VBA that can query a named range in VBA using SQL. Currently, it works reasonably well, but i have the problem that every time i run the macro a read-only instance of the worksheet is opened. I want to use the macro to query ranges within the same workbook without opening a read-only copy.
Here is my code
Public Sub QueryAndOutputToCell(ByVal query As String, rng As Range)
Dim conn As ADODB.Connection
Set conn = New ADODB.Connection
Dim DBFullName, connString, SQL As String
DBFullName = ThisWorkbook.path & "\" & ThisWorkbook.name
connString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & DBFullName & "';Extended Properties='Excel 12.0;HDR=Yes;IMEX=1';"
conn.connectionString = connString
conn.Open ' Read-only copy is opened here
conn.commandtimeout = 0
Dim cubeData As ADODB.Recordset
Set cubeData = New ADODB.Recordset
cubeData.Open query, conn, adOpenDynamic, adLockReadOnly
rng.CopyFromRecordset cubeData
cubeData.Close
conn.Close
Set cubeData = Nothing
Set conn = Nothing
End Sub
Do anyone know if this is possible?
Related
I have a working VBA code that exports data from MS Access data and pastes it into MS Excel Sheet cells and using cell range as RowSource to appear data in the ListBox.
Is there a way to paste directly the imported data into ListBox instead of pasting into Sheet cells?
Sub IBDocsLibSearch()
Dim cnn As ADODB.Connection 'dim the ADO collection class
Dim rs As ADODB.Recordset 'dim the ADO recorset class
Dim dbPath As String
Dim MyDbPassword As String
Dim SQL As String
Dim i As Integer
Dim var1
Application.ScreenUpdating = False
IBDocLibSheet.Range("A2:I500000").ClearContents
dbPath = LinkSheet.Range("C4").Value 'Inbound Checklist Database Location
MyDbPassword = PWSheet.Range("C3").Value 'Password to connect the Excel to Access
Set var1 = IBUserForm.IBDTextSerialNo
'Initialise the collection class variable
Set cnn = New ADODB.Connection
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath & ";Jet OLEDB:Database Password=" & MyDbPassword
SQL = "SELECT * FROM DB_IBDocuments WHERE SerialNo = '" & var1.Value & "'"
Set rs = New ADODB.Recordset
rs.Open SQL, cnn
If rs.EOF And rs.BOF Then
'Close the recordset and connection
rs.Close
cnn.Close
'Clear Memory
Set rs = Nothing
Set cnn = Nothing
Application.ScreenUpdating = True
Exit Sub
End If
IBDocLibSheet.Range("A2").CopyFromRecordset rs '----This is where to paste the extracted data
'To show results in Listbox
IBUserForm.IBDListBox.RowSource = "IBL_DocLib"
'Close the recorset and connections
rs.Close
cnn.Close
'Clear memory
Set rs = Nothing
Set cnn = Nothing
Application.ScreenUpdating = True
End Sub
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:
The data pulled in doesn't include Row1 of the dataset (so the headers aren't pulled in)
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?
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
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
I cant seem to find an easy way of doing outside of just accessing the SQL from ACCESS SQL View and doing it manually. Is there some magic way to use this code below and do that?
Its worth pointing out that I am trying to do this from Excel's VBA.
Private Sub tryagain()
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Set con = New ADODB.Connection
With con
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Open "C:\Users\Ashleysaurus\Desktop" & "\" & "xyzmanu3.accdb"
End With
con.Execute "Invoice Query"
'How do output to Worksheet?
rs.Close
cmd.ActiveConnection.Close
End Sub
Simply use the ADO recordset object which you initialize, call the query, and then run the Range.CopyFromRecordset method (specifying the leftmost worksheet cell to place results).
Also, see the changed connection open routine with proper connection string. And because recordsets do not pull in column headers automatically but only data, an added loop was included iterating through recordset's field names.
Private Sub tryagain()
Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim strConnection As String
Dim i as Integer, fld As Object
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source='C:\Users\Ashleysaurus\Desktop\xyzmanu3.accdb';"
con.Open strConnection
rs.Open "SELECT * FROM [Invoice Query]", con
' column headers
i = 0
Sheets(1).Range("A1").Activate
For Each fld In rs.Fields
ActiveCell.Offset(0, i) = fld.Name
i = i + 1
Next fld
' data rows
Sheets(1).Range("A2").CopyFromRecordset rs
rs.Close
cn.Close
End Sub
By the way, this same above setup can even query Excel workbooks as the Jet/ACE SQL Engine is a Windows technology (.dll files) available to all Office or Windows programs.
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source='C:\Path\To\Workbook.xlsm';" _
& "Extended Properties=""Excel 8.0;HDR=YES;"";"
strSQL = "SELECT * FROM [Sheet1$]"
I'm trying to open a CSV file and query it and return the results into column A of the second worksheet of "ThisWorkbook".
I'm not getting any errors so I do not see why it is not copying the record set into excel.
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Set con = New ADODB.Connection
Set rs = New ADODB.Recordset
Dim currentDataFilePath As String
Dim currentDataFileName As String
Dim nextRow As Integer
currentDataFilePath = "C:\Users\M\folder\"
currentDataFileName = "csv-file"
con.Open "Provider=Microsoft.JET.OLEDB.4.0;" & _
"Data Source=" & currentDataFilePath & ";" & _
"Extended Properties=""text;HDR=NO;FMT=Delimited;IMEX=1"""
'rs.ActiveConnection = con
rs.Open "SELECT Name FROM [" & currentDataFileName & ".csv] WHERE Datatype ='TYPE3'",
con
ThisWorkbook.Worksheets("Sheet2").Range("A:A").CopyFromRecordset rs
rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
End Sub
You might refer to the CopyFromRecordset() method.
Based on your code above, after the rs.Open command you would add something like this:
ActiveWorksheet.Range("A1").CopyFromRecordset rs
See more here: http://msdn.microsoft.com/en-us/library/office/ff839240%28v=office.15%29.aspx
I try to make macro that operate with sql statements with ADO liblary, but actually it returns only 6559 records, while one of my table have 72k records.
Why?
Recently, I've noticed, that actually my code does not returns 6559, but rows number - 65537. So when I decrease number of the rows in sheet to 72092, I even gets less rows (6550).
Another thing I noticed is that rs.RecordCount returns "-1".
Here is code for my subproccedure. It have three parameters: sql statement (sqlstmt), destination sheet name (sheet_name) and destination range (destination1).
'subprocedure that execute sql statements and save resault in given worksheet
Public Sub sql_query(ByVal sqlstmt As String, ByVal sheet_name As String, ByVal destination1 As String)
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim connstring As String
Dim qt As QueryTable
Dim tw_path As String
Dim is_name As Boolean
Dim sh As Worksheet
'''making sheet if it doesn't exist
is_name = False
For Each sh In ThisWorkbook.Worksheets
If sh.Name = sheet_name Then is_name = True
Next
If is_name = False Then ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)).Name = sheet_name
''' connection
tw_path = ThisWorkbook.path & "\" & ThisWorkbook.Name
connstring = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & tw_path & ";Extended Properties=Excel 8.0;Persist Security Info=False"
Set conn = New ADODB.Connection
conn.ConnectionString = connstring
conn.Open
'''executing statement
Set rs = New ADODB.Recordset
rs.Source = sqlstmt
rs.ActiveConnection = conn
rs.Open
'''saving records
ThisWorkbook.Worksheets(sheet_name).Activate
Set qt = Worksheets(sheet_name).QueryTables.Add(Connection:=rs, Destination:=Range(destination1))
qt.Refresh
'''end
If rs.State <> adStateClosed Then rs.Close
conn.Close
If Not rs Is Nothing Then Set rs = Nothing
If Not conn Is Nothing Then Set conn = Nothing
Set qt = Nothing
End Sub
Thanks for help
I'm guessing you are using excel 2003 or a prior version, in which case a worksheet has a maximum of 65,536 rows. I would've put this in a comment instead of an answer but I'm 1 rep short of being able to comment :(. Sorry