I am pretty unfamiliar with VB code and trying to solve an issue. Several users can run this macro fine, but some get a Run-time error 1004, General ODBC error. Debug points to the last line below. It is odd to me that it is setup to connect simply to a directory of a file share. Anyone know what may be going on? I have verified they have access to the share.
Option Explicit
Sub CreatePolicyTable()
Dim qryTable As QueryTable
Dim rngDestination As Range
Dim strConnection As String
Dim strSQL As String
Dim strParam1 As String
Dim strParam3 As String
Worksheets("Pol Data").Range("A1:A1048576").EntireRow.ClearContents
Call Delete_Named_Ranges
'Define the connection string and destination range.
strConnection = "ODBC;Driver={Microsoft Text Driver (*.txt; *.csv)};" & _
"DBQ=\\My Folder\;" & _
"Extensions=asc,csv,tab,txt;"
Set rngDestination = Sheet2.Range("A1")
'Create the SQL string.
strSQL = "SELECT * FROM My_File.csv"
'set the parameter strings
strParam1 = " WHERE state = '" & Sheet5.ComboBox1.Text & "'"
strParam3 = " ;"
'check & build variable parameters depending on whether combobox ticked by user
strSQL = strSQL & strParam1 & strParam3
'Create the QueryTable.
Set qryTable = Sheet2.QueryTables.Add(strConnection, rngDestination)
'Populate the QueryTable.
qryTable.CommandText = strSQL
qryTable.CommandType = xlCmdSql
qryTable.BackgroundQuery = False
qryTable.Refresh
'Create Named Ranges
ActiveWorkbook.Names.Add Name:="PolData", RefersToR1C1:= _
"=OFFSET('Pol Data'!R1C1,0,0,COUNTA('Pol Data'!C1),COUNTA('Pol Data'!R1))"
End Sub
Sub Refresh_All()
Call CreatePolicyTable
Worksheets("Competitive Analysis").PivotTables("1").PivotCache.Refresh
Worksheets("Competitive Analysis").Activate
End Sub
Sub Delete_Named_Ranges()
Dim wbBook As Workbook
Dim nName As Name
Set wbBook = ActiveWorkbook
For Each nName In wbBook.Names
nName.Delete
Next nName
End Sub
Related
As to me, ADODB is something new for me that I am eager to learn. Here's a code that I tried my best but needs your ideas to make it appear more professional and more efficient. The problem in the code is that the data is grabbed from sheets in reverse order and not in the order of sheets. To make it clear, I have Sample.xlsx workbook with two sheets Sheet1 and New and the code is supposed to loop through t he sheets then search for specific header then to get the data from such a column. All this with the ADO approach. the code grabs the data from New sheet first then from Sheet1 .. While the order of the sheets is Sheet1 then New >> another point, how can I close the recordset properly. I mean is using .Close is enough or I have to set it to Nothing Set rs=Nothing.
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
the code grabs the data from New sheet first then from Sheet1 .. While the order of the sheets is Sheet1 then New
The tab order is an Excel feature. The Sheet names are extracted in alphabetical order when you use ADODB. This is the reason why you get New sheet first and then Sheet1.
Note: If the sheet names start with number or have spaces then they are given a priority first. Few examples
Example 1
Sheets names: 1, Sheet1, 1Sheet4, She et3, Sheet5
Returned as
'1$'
'1Sheet4$'
'She et3$'
Sheet1$
Sheet5$
Example 2
Sheets names: Sheet2, Sheet5, She et3, Sheet1, Sheet4
Returned as
'She et3$'
Sheet1$
Sheet2$
Sheet4$
Sheet5$
Example 3
Sheets names: 1, Sheet1, 2, Sheet2, 3, Sheet3
Returned as
'1$'
'2$'
'3$'
Sheet1$
Sheet2$
Sheet3$
Alternative to ADODB
If you want to extract the names of the sheets in the tab order then you can use DAO as shown by Andrew Poulsom in THIS link. Posting the code here in case the link dies...
Sub GetSecondSheetName()
' Requires a reference to Microsoft DAO x.x Object Library
' Adjust to suit
Const FName As String = "P:\Temp\MrExcel\Temp\SheetNames.xls"
Dim WB As DAO.Database
Dim strSheetName As String
Set WB = OpenDatabase(FName, False, True, "Excel 8.0;")
' TableDefs is zero based
strSheetName = WB.TableDefs(1).Name
MsgBox strSheetName
WB.Close
End Sub
Close is enough or I have to set it to Nothing Set rs=Nothing.
No you do not have to set it to nothing. VBA cleans it automatically when it exits the prodecure. But yes it is a good practice to flush the toilet.
Interesting Read:
You may want to read the post by #GSerg in the below link...
When should an Excel VBA variable be killed or set to Nothing?
For it to work with XLSX, use this (Requires a reference to Microsoft Office XX.XX Access database engine Object Library)
Option Explicit
'~~> Change this to the relevant file name
Const FName As String = "C:\Users\routs\Desktop\Delete Me later\TEXT.XLSX"
Sub Sample()
'Requires a reference to Microsoft Office XX.XX Access database engine Object Library
Dim db As DAO.Database
Set db = OpenDatabase(FName, False, False, "Excel 12.0")
Dim i As Long
For i = 0 To db.TableDefs.Count - 1
Debug.Print db.TableDefs(i).Name
Next i
db.Close
End Sub
In Action
#Siddharth Rout you have inspired me how to search for such new topic for me and I could use such a code to list all the worksheets in the order of tab using DAO but with late binding ( I am curious to know how to use early binding as I tried but with no success)
Sub Get_Worksheets_Using_DAO()
Dim con As Object, db As Object, sName As String, i As Long
Set con = CreateObject("DAO.DBEngine.120")
sName = ThisWorkbook.Path & "\Sample.xlsx"
Set db = con.OpenDatabase(sName, False, True, "Excel 12.0 XMl;")
For i = 0 To db.TableDefs.Count - 1
Debug.Print db.TableDefs(i).Name
Next i
db.Close: Set db = Nothing: Set con = Nothing
End Sub
I am using an Access Db to export some information to an Excel Workbook. I am using an input form to add dates to the query that creates the sheet. If I create 1 sheet the export works. If I create more than one sheet once the query goes to the second sheet the focus stays on the excel spreadsheet. If you enter a date it goes on cell A1 of the spreadsheet instead of the input box. Any help is appreciated.
Public Function ExportSpreadSheet(path As String)
Dim xlPath As String, I As Integer
Dim DB As Database
Dim myrs As Recordset ' Create a recordset to hold the data
Dim strSQL As String
Dim myExcel As New Excel.Application ' Create Excel with Early binding
Dim wrkbk As Object
Dim wrksht As Object
Dim targetworkbook As Excel.Workbook
Dim FileRange, name As String
Dim extraChar, queryForTransfer, searchSheet As String
Dim objXL As Object
Dim objAC As Object
Dim x As Integer
Dim myFileName As String
Dim sheetDate As String
Dim sheetName As String
Dim amtofsheets As Long
Dim s As Long
Dim ctlCurrentControl As Control
Dim strAnswer As String
On Error GoTo Err_ExportSpreadSheet
DoCmd.SetWarnings False
xlPath = path
amtofsheets = InputBox("Enter amount of sheets", "Amount of Sheets")
Set DB = CurrentDb
Set objAC = CreateObject("Access.application", "")
For s = 1 To amtofsheets
strAnswer = Forms("Browse1").txtFileSelection
sheetDate = InputBox("Enter Trade Date of Entries ex 10/04/2017", "Trade Date")
If s = 1 Then Set objXL = CreateObject("Excel.application", "")
If s = 1 Then objXL.Visible = True
If s = 1 Then objXL.DisplayAlerts = True
If s = 1 Then Set targetworkbook = objXL.Workbooks.Add
'Add worksheet if need more than three worksheets
strSQL = "SELECT FXOpenDeals.city, FXOpenDeals.[As of Date], FXOpenDeals.[Cnt Pty name], FXOpenDeals.[deal number], FXOpenDeals.value, FXOpenDeals.ccy1, FXOpenDeals.[ccy1 amt], FXOpenDeals.ccy2, FXOpenDeals.[ccy2 amt], FXOpenDeals.[unrealized G/L_PV] " _
& " FROM [A1-Internal_Customers] INNER JOIN FXOpenDeals ON [A1-Internal_Customers].[counterparty number] = FXOpenDeals.[counterparty number] " _
& " WHERE FXOpenDeals.[trade] = #" & Format(sheetDate, "mm/dd/yyyy") & "#" _
& " ORDER BY FXOpenDeals.[Cnt Pty name];"
Set myrs = DB.OpenRecordset(strSQL)
If amtofsheets = 1 Or amtofsheets = 2 Then
For I = 1 To targetworkbook.Worksheets.Count
sheetName = "Sheet" & I
Select Case sheetName
Case "Sheet2"
targetworkbook.Sheets("Sheet2").Delete
Case "Sheet3"
targetworkbook.Sheets("Sheet3").Delete
End Select
Next I
End If
If s > 3 Then
With targetworkbook
.Sheets.Add After:=Sheets(Worksheets.Count)
ActiveSheet.name = "Sheet" & s
End With
End If
'Get spreadsheet headers
x = 0
For Each Field In myrs.Fields 'RS being my Recordset variable
targetworkbook.Worksheets("Sheet" & s).Range("A1").Offset(0, x).Value = Field.name
x = x + 1
Next Field
targetworkbook.Worksheets("Sheet" & s).Range("A2").CopyFromRecordset myrs
targetworkbook.Worksheets("Sheet" & s).Columns("A:K").AutoFit
'Name Worksheet
sheetName = Format(sheetDate, "mm-dd")
targetworkbook.Sheets("Sheet" & s).name = sheetName
Next s
DoCmd.SetWarnings False
myFileName = "Internal Customer FX Deals"
targetworkbook.SaveAs FileName:=xlPath & myFileName, FileFormat:=xlWorkbookNormal
targetworkbook.Close SaveChanges:=False
DoCmd.SetWarnings True
If Not objXL Is Nothing Then
objXL.Quit
objXL.DisplayAlerts = True
Set objXL = Nothing
Set myrs = Nothing
End If
MsgBox "Internal Customer FX Deals Data successfully Exported", vbOKOnly
Exit_ExportSpreadSheet:
Exit Function
Err_ExportSpreadSheet:
Err.Clear
Resume Exit_ExportSpreadSheet
End Function
Seems to me that you are doing a whole lot of work for nothing. There's not need to automate Excel unless you want to do some formatting. Simply export the query to Excel via TransferSpreadsheet. Instead of the input box, use a parameter in the query, or better yet, a small form with a textbox.
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "yourQueryName", "FileName", True, "SheetName"
I'm using the SQLite ODBC Driver v0.9993 in Excel 2016 (win10). The main impetus for using an external source is that I have too much data for Excel to sanely manage, so it will be pulled based on user-selected criteria. Because of this, I'd like to use parameterized queries based on the contents of well-defined worksheet cells.
I'm trying two methods:
Straight VBA, where I do something like this (rough code):
Sub UpdateTables()
Dim ws as Worksheet
Dim adoCN As ADODB.Connection
Dim adoCmd As ADODB.Command
Dim adoRS As ADODB.Recordset
Dim sDB as String
Dim rCell as Range
Set adoCN = New ADODB.Connection
Set adoRS = New ADODB.Recordset
' ws is set to correct worksheet
' ...
' define sDB from worksheet cell
With adoCN
.Open "Provider=MSDASQL.1;Persist Security Info=True;" _
& "Driver={SQLite3 ODBC Driver};" _
& "Database=" & sDB & ";" _
& "DSN=SQLite3 Datasource;LongNames=true;fksupport=true", "", "" '
End With
Set adoCmd = New ADODB.Command
adoCmd.ActiveConnection = adoCN
' rCell points to cell containing query parameter
Set adoParam = adoCmd.CreateParameter(, adVarChar, adParamInput, _
Len(rCell.value), rCell.value)
adoCmd.Parameters.Append adoParam
adoCmd.CommandText = "SELECT * FROM TableName WHERE X = ?"
adoRS.Open Source:=adoCmd, CursorType:=adOpenKeyset
With ws.ListObjects(1).QueryTable
Set .RecordSet = adoRS
.Refresh ' errors with "Error 1004: invalid accessor flag"
End With
End Sub
(Code has been simplified, generally I include sanity checks.)
GUI-based in Excel, with New Query > From Other Sources > From ODBC, set DSN to "SQLite3 Datasource", and enter in the Connection string used above.
Unfortunately, the "Parameters" button (Connections > select query > Properties > Definition tab) is grayed out.
I think I prefer the second solution, but neither is working at the moment.
Rather than opening recordset via an ADO connection, you need to execute the command from ADO command object. This an often discussed topic of recordset .execute vs .open. Of course, be sure to add error handling to capture relevant errors/exceptions.
Sub UpdateTables()
On Error GoTo ErrHandle
Dim ws as Worksheet
Dim adoCN As New ADODB.Connection, adoRS As New ADODB.Recordset
Dim adoCmd As New ADODB.Command
Dim sDB as String
Dim rCell as Range
'Set ws = ... '
'sDB = ... '
' DATABASE CONNECTION '
adoCN.Open "Provider=MSDASQL.1;Persist Security Info=True;" _
& "Driver={SQLite3 ODBC Driver};" _
& "Database=" & sDB & ";" _
& "DSN=SQLite3 Datasource;LongNames=true;fksupport=true", "", ""
' ADO COMMAND '
With adoCmd
.ActiveConnection = adoCN
.CommandText = "SELECT * FROM TableName WHERE X = ?"
.CommandType = adCmdText
.Parameters.Append .CreateParameter(, adVarChar, adParamInput, _
Len(rCell.value), rCell.value)
End With
' EXECUTE RECORDSET '
Set adoRS = adoCmd.Execute
' DEFINE QUERYTABLE '
With ws.ListObjects(1).QueryTable
Set .RecordSet = adoRS
.Refresh
End With
' CLOSE AND FREE RESOURCES '
adoRS.Close: adoCN.Close
Set adoRS = Nothing: Set adoCmd = Nothing: Set adoCN = Nothing
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description
Set adoRS = Nothing: Set adCmd = Nothing: Set adCN = Nothing
Exit Sub
End Sub
I am creating an ADODB connection to a Sybase database, executing an SQL statement into a recordset, and then using the CopyFromRecordset method to paste the contents of the recordset to a range. This has been working fine but I recently moved PC's at work and now one of the columns is returning nothing.
When I run the same SQL in SQuirreL the column is not blank.
If I pause the VBA and try to look at one of the values in the column / field in question (ie ?rst.fields(1).value in the immediate Window) I get the following error message:
Run-time error '-2147467259 (80004005)': Unspecified error.
In the Squirrel results Metadata tab the column in question is described as:
ColumnIndex 2
getColumnName CommentText
getColumnTypeName text
getPrecision 2147483647
getScale 0
isNullable 0
getTableName xxxxxxx
getSchemaName
getCatalogName
getColumnClassName java.sql.Clob
getColumnDisplaySize 2147483647
getColumnLabel CommentText
getColumnType 2005
isAutoIncrement FALSE
isCaseSensitive FALSE
isCurrency FALSE
isDefinitelyWritable FALSE
isReadOnly FALSE
isSearchable FALSE
isSigned FALSE
isWritable TRUE
The code in question is below, but, as stated the code does not seem to be the problem as it has worked previously - any ideas?
Sub ImportComments()
Dim wsData As Worksheet
Dim rng As Range
Dim cn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim x As Long
Dim rngSQL As Range
Dim cell As Range
Dim sSQL As String
Dim sProvider As String
Dim sDS As String
Dim sDataSource As String
Dim sUser As String
Dim sCatalog As String
Dim sPassword As String
Dim rngDS As Range
Dim rngThisDS As Range
Dim sConnect As String
Dim sInstance As String
Dim fSuccess As Boolean
Dim sError As String
On Error GoTo ProcExit
'delete previous comments if they exist
If SheetExists("Comments_Data_Import", ThisWorkbook) = True Then
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Comments_Data_Import").Delete
Application.DisplayAlerts = True
End If
'create comments sheet
Set wsData = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets("EWI_Data_Import"))
wsData.Name = "Comments_Data_Import"
'build sql string
Set rngSQL = Range(ThisWorkbook.Sheets("SQL").Range("A2"), _
ThisWorkbook.Sheets("SQL").Range("A2").End(xlDown))
For Each cell In rngSQL
sSQL = sSQL & cell.Value & " "
Next cell
'define login components
Set rngDS = ThisWorkbook.Worksheets("Login").Range("rngInstance").CurrentRegion
Set rngDS = rngDS.Offset(1, 0).Resize(rngDS.Rows.Count - 1)
sProvider = "Provider=ASEOLEDB.1;"
sUser = "User ID=" & ThisWorkbook.Worksheets("Login").Range("rngUsername").Value & ";"
sPassword = "Password=" & ThisWorkbook.Worksheets("Login").Range("rngPassword").Value
'try to log in to each instance exiting when succesful
Set cn = New ADODB.Connection
cn.CommandTimeout = 600
'turn off error hadling to allow for connection errors On Error Resume Next
For Each rngThisDS In rngDS.Rows
'complete connect string
Err = 0
sInstance = rngThisDS.Cells(1, 1)
sDS = "Data Source=" & rngThisDS.Cells(1, 2) & ";"
sCatalog = "Initial Catalog=" & rngThisDS.Cells(1, 3) & ";"
sConnect = sProvider & sDS & sUser & sCatalog & sPassword
'attempt to open
cn.Open sConnect
'If successful Then
If Err = 0 Then
'flag success
fSuccess = True
'execute SQL
On Error GoTo ProcError
Set rst = cn.Execute(sSQL)
'copy data into comments sheet
wsData.Range("A2").CopyFromRecordset rst
'Put in the headers
Set rng = wsData.Range("A1")
For x = 1 To rst.Fields.Count
rng.Offset(0, x - 1).Value = rst.Fields(x - 1).Name
Next x
FormatComments
Exit For
End If
Next rngThisDS
If fSuccess = False Then
MsgBox ("Unable to connect to Insight")
Else
MsgBox "Connected to and exported data from " & sInstance
End If
ProcExit:
Set wsData = Nothing
Set rng = Nothing
Set cn = Nothing
Set rst = Nothing
Set rngSQL = Nothing
Set cell = Nothing
Set rngDS = Nothing
Set rngThisDS = Nothing
Exit Sub
ProcError:
MsgBox "Error: " & Err.Description
Resume ProcExit
End Sub
According to the CopyFromRecordset() MSDN:
When this method copies the recordset to the worksheet, the results
will be truncated if you do not specify a range that is large enough
to hold the contents of the recordset.
Consider specifying the range with MoveFirst command reset:
' Copy data into comments sheet
rst.MoveLast
rst.MoveFirst
wsData.Range("A2:Z500").CopyFromRecordset rst
Or entire worksheet (starting at A1, of course inserting row for column headers)
wsData.Cells.CopyFromRecordset rst
But even then, CopyFromRecordset() is sensitive to data and cursory types even memory (since you pull all data and dump at once), so consider altogether replacing the method and iterate through records for the rows. Even other languages (PHP, Python, Java, etc.) run queries this way, opening cursor and iterating through resultset.
' Put in the headers
Set rng = wsData.Range("A1")
For x = 1 To rst.Fields.Count
rng.Offset(0, x - 1).Value = rst.Fields(x - 1).Name
Next x
' Put in rows
Dim col As Integer, row As Integer
rst.MoveLast
rst.MoveFirst
Set rng = wsData.Range("A2")
row = 0
Do While Not rst.EOF
For col = 0 To rst.Fields.Count - 1
rng.Offset(row, col).Value = rst(col)
Next col
row = row + 1
rst.MoveNext
Loop
I have a workbook with multiple sheets, and have created Named Tables (NOT ranges) in the work book. For illustrative purposes, these table names are tblA, tblB, and tblC. I am unable to find a way to query these tables via ADO or ODBC. I can access named ranges, but this will not work for my needs.
Thanks!
I don't know if it can be done directly but will be interested to see if anyone comes back with a working method. The GetSchema collection of ADO only seems to pick up sheetnames and named ranges but not ListObjects which named tables are. Below is a workaround but it means opening Excel to find the header/data range of the table. It's almost pointless using ADO or similar then as you can copy the data directly but I suppose you could convert to a named range before saving as a one-off task?
Option Explicit
Sub test()
Dim WB As Workbook, WS As Worksheet, strExcelfile As String, strSheetName As String
Dim strTableName As String, objListObj As ListObject, HeaderRange As String
Dim strSQL As String, DataRange As String
strExcelfile = "C:\Users\osknows\Desktop\New folder\test.xlsm"
strSheetName = "Sheet1"
strTableName = "TableName"
Set WB = GetObject(strExcelfile) 'Filepath & Filename
Set WS = WB.Sheets(strSheetName) 'SheetName
Set objListObj = WS.ListObjects(strTableName) 'Table Name
'get range of Table
HeaderRange = objListObj.HeaderRowRange.Address
DataRange = objListObj.DataBodyRange.Address
'write data directly if required
With ThisWorkbook
With Sheet1
'.Range(HeaderRange).Value = WS.Range(HeaderRange).Value
'.Range(DataRange).Value = WS.Range(DataRange).Value
End With
End With
'or use ADODB which is a bit pointless now!
Dim cnn1 As New ADODB.Connection
Dim rst1 As New ADODB.Recordset
cnn1.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strExcelfile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
strSQL = "SELECT * FROM [" & strSheetName & "$" & Replace(DataRange, "$", "") & "];"
rst1.Open strSQL, cnn1, adOpenStatic, adLockReadOnly
'tidy up
Set objListObj = Nothing
Set WS = Nothing
WB.Close
Set WB = Nothing
End Sub