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
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 trying to create a pivot table but I keep running into an error.
Here is my code so far.
Sub Practice()
Dim wb As Workbook
Dim ws As Worksheet
Dim pvtc As PivotCache
Dim pvt As PivotTable
Dim str As String
str = "Jul 26"
Set wb = ActiveWorkbook
'Create Pivot Worksheet
Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
ws.Name = str
'Create Pivot Cache
Set pvtc = wb.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:="Lignes!" & wb.Sheets("Lignes").Cells(1, 1).CurrentRegion.Address)
'Create Pivot Table
Set pvt = pvtc.CreatePivotTable( _
TableDestination:=ws.Name & "!" & ws.Cells(1, 1).Address, _
TableName:="Table1")
End Sub
The error occurs specifically at the last step when I create the pivot table.
What's wrong with it?
Edit: It was suggested I wrap my sheet name with single quotes (since it contains a space) if I pass a string to the TableDestination argument. I tried this
'Create Pivot Table
Set pvt = pvtc.CreatePivotTable( _
TableDestination:="'" & ws.Name & "'!A1", _
TableName:="Table1")
but I am still getting the same error.
Better to just use a Range object here:
TableDestination:=ws.Cells(1,1)
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
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
This is related to
Excel / VBA Remove duplicate rows by cross referencing 2 different sheets then deleting 1 row
I can't seem to get any VBA to work well or fast enough for a couple 100 rows.
Does Excel have a formula to remove duplicates from one sheet, by cross referencing another sheet?
Thanks for all your help.
Here is a much faster VBA solution, utilizing a dictionary object. As you can see, it loops only once through sheet A and sheet B, while your original solution has a running time proportional to "number of rows in sheet A" * "number of rows in sheet B".
Option Explicit
Sub CleanDupes()
Dim wsA As Worksheet
Dim wsB As Worksheet
Dim keyColA As String
Dim keyColB As String
Dim rngA As Range
Dim rngB As Range
Dim intRowCounterA As Integer
Dim intRowCounterB As Integer
keyColA = "A"
keyColB = "B"
intRowCounterA = 1
intRowCounterB = 1
Set wsA = Worksheets("Sheet A")
Set wsB = Worksheets("Sheet B")
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Do While Not IsEmpty(wsA.Range(keyColA & intRowCounterA).Value)
Set rngA = wsA.Range(keyColA & intRowCounterA)
If Not dict.Exists(rngA.Value) Then
dict.Add rngA.Value, 1
End If
intRowCounterA = intRowCounterA + 1
Loop
intRowCounterB = 1
Do While Not IsEmpty(wsB.Range(keyColB & intRowCounterB).Value)
Set rngB = wsB.Range(keyColB & intRowCounterB)
If dict.Exists(rngB.Value) Then
wsB.Rows(intRowCounterB).Delete
intRowCounterB = intRowCounterB - 1
End If
intRowCounterB = intRowCounterB + 1
Loop
End Sub
You can do a lot with ADO and Excel.
Dim cn As Object
Dim rs As Object
Dim wb As Workbook
Dim sSQL As String
Dim sFile As String
Dim sCon As String
Dim sXLFileToProcess As String
Dim i
sXLFileToProcess = "Book1z.xls"
sFile = Workbooks(sXLFileToProcess).FullName
''Note that if HDR=No, F1,F2 etc are used for column names,
''if HDR=Yes, the names in the first row of the range
''can be used.
''This is the Jet 4 connection string, you can get more
''here : http://www.connectionstrings.com/excel
sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open sCon
'' In this example, the column header for column F is F, see notes
'' above on field (column) names. It also assumes that the sheets to
'' be merged have the same column headers in the same order
'' It would be safer to list the column heards rather than use *.
sSQL = sSQL & "SELECT b.Key,b.b,b.c,b.d,b.e FROM [SheetB$] As B " _
& "LEFT JOIN [SheetA$] As A " _
& "ON B.Key=A.Key " _
& "WHERE A.Key Is Null"
rs.Open sSQL, cn, 3, 3
Set wb = Workbooks.Add
With wb.Worksheets("Sheet1")
For i = 1 To rs.Fields.Count
.Cells(1, i) = rs.Fields(i - 1).Name
Next
.Cells(2, 1).CopyFromRecordset rs
End With
''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing