How can make user-defined-function with ADO connection - excel

Please help me create a user defined function in excel vba
example
Function GetTheValue(wbPath, wbName, wsName, cellRef)
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim tmp As Range
Set cnn = New ADODB.Connection
Set rst = New ADODB.Recordset
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & wbPath & wbName & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"""
rst.Open "SELECT * FROM [" & wsName & "$" & cellRef & "]", cnn
Set tmp = Range("L5")
tmp.CopyFromRecordset rst
MsgBox tmp.Value
GetTheValue = tmp.Value
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
End Function
I tryed to use this in cell by signing formula
=GetThaValue("D:\";"test.xls";"Sheet1";"B4")
and see that the string "tmp.CopyFromRecordset rst" of my code did not work
Please can you help me resolve this question.
Thanks a lot

If you want to call this function from any excel cell there are some changes required.
First- I made some test and it seems to be not allowed to point single cell in SQL statement, therefore it will be required to call your function in this way:
=GetThaValue("D:\";"test.xls";"Sheet1";"B4:B5")
where first cell B4 will be one you search.
Second- The function slightly improved with some comments inside looks as follows:
Function GetTheValue(wbPath, wbName, wsName, cellRef)
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim tmp As Range
Set cnn = New ADODB.Connection
Set rst = New ADODB.Recordset
'some changes here according to www.ConnectionStrings.Com
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & wbPath & wbName & ";" & _
"Extended Properties=""Excel 8.0;"""
rst.Open "SELECT * FROM [" & wsName & "$" & cellRef & "]", cnn
'Set tmp = Range("L5") 'NOT needed here
'tmp.CopyFromRecordset rst 'NOT allowed if function is called from Excel
'MsgBox tmp.Value 'NOT necessary in this function
'NEW- in this way we get value of your cell and pass it to excel
GetTheValue = rst.Fields(0).Value
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
End Function
I can confirm it's tested for Excel 2010 and it's working fine.

Related

Connectionstring vba with blank space in dataname get broken

My Code is following. I'll try to copy a range of data from a closed sheet with connectionstrings. The Code is okay if the dataname hasn't a empty string.
e.g. test.xlsx is okay but test further.xlsx get broken.
'using sql
Sub ImportThisFile(FilePath As String, SourceSheet As String, Destination As Range)
Set Conn = New ADODB.Connection
'xls
'Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
' FilePath & ";Extended Properties=Excel 8.0;"
'xlsx
Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & _
FilePath & ";Extended Properties=Excel 12.0 Xml;"
Sql = "SELECT * FROM [" & SourceSheet & "$] WHERE [fieldname] <> " & [""""""]
Set RcdSet = New ADODB.Recordset
RcdSet.Open Sql, Conn, adOpenForwardOnly
Destination.CopyFromRecordset RcdSet
RcdSet.Close
Set RcdSet = Nothing
Conn.Close
Set Conn = Nothing
End Sub
Sub StartDoingStuff()
Dim Zeit As Long, Anzahl As Long
Anzahl = 1
Zeit = Timer
Dim testvar As String, testvar2 As String, testvar3 As String
testvar = "C:\Users\Admin\Desktop\Folder\"
testvar2 = "testdata with emptystrings.xlsx.xlsx"
testvar2 = "test.xlsx"
testvar3 = "Tabelle1"
ImportThisFile testvar & testvar2, "Timesheet", Range(testvar3 & "!A2")
Debug.Print "Zeitbedarf"; Round(Timer - Zeit, 3)
End Sub
And Second Question.
If I want to copy a range, how i must write the code?
I need to determine the last cell in a column. How is that possible ?
the code i posted is correct. It was a mistake in the workbook (tablename)

ADODB Recordset error when Range Column is beyond "Z"

I am using ADODB to get data from a closed excel file. I get an error when I use columns beyond column Z in my query.
Sub TestExcelWB()
Dim cn As Object
Dim szConnect As String
Dim SourceFile As String
Dim SourceSheet As String
Dim SourceRange As String
Dim rsData As Object
'-----For ADODB connection-----
SourceFile = ThisWorkbook.Path & "\ADO Test2.xlsm"
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
Set cn = CreateObject("ADODB.Connection")
cn.Open szConnect
'---^^
'-----For Recordset-----
Set rsData = CreateObject("ADODB.Recordset")
SourceSheet = "Sheet1"
SourceRange = "Z1:AA10"
szSQL2 = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
rsData.Open szSQL2, cn, 0, 1, 1
'---^^
cn.Close
End Sub
When I change the variable SourceRange = "A1:Z10" then there is no error. Is this a limit of the provider. Is there a way around this?

Use SQL to Query another excel file

I'm try an alternative to solve this issue using VBA to get the data.
The following code works fine when "Tbltest" is a range but not working when the name represent a table. How can I make it work with Table not range.
Function ConnectToExelPRJReview()
Dim Xlpath As String
On Error GoTo ErrHandlerconnection:
Dim Xlcn As ADODB.Connection
Dim Xlrs As ADODB.Recordset
Xlpath = "\\xxx.xxx.xxxxxx.net\project_review\wip\" & "filetotest.xlsm"
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Xlpath _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
Set Xlcn = CreateObject("ADODB.Connection")
Set Xlrs = CreateObject("ADODB.Recordset")
Xlcn.Open strCon
strSQL = "SELECT * FROM [Tbltest]"
Xlrs.Open strSQL, Xlcn
'display the first data
MsgBox Xlrs.Fields(0).Value
Xlcn.Close
Exit Function
ErrHandlerconnection:
MsgBox Err.Number & " " & Err.Description, vbCritical, "EXCEL CONNECTION ERROR"
End Function

Replace Worksheets content without opening it

I am using ADO model to gather data from various closes workbooks. This is working well.
I now want to put this data in another closed workbook, but I would like to be able to delete a sheet content before.
How can I delete a worksheet content without opening the workbook using VBA ?
How can I transfer a record set to a closed wb ? / Copy one table to another using ADO ?
EDIT :
I was able to insert some data from one workbook to another one in a new sheet but I can't get to output data in an existing worksheet.
When I try the INSERT INTO statement, an error is raised. Update impossible, database or object readonly.
Here is the code :
Sub tranfert()
Dim ExcelCn As ADODB.Connection
Dim ExcelRst As ADODB.Recordset
Dim Cn As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim maBase As String, maFeuille As String
Dim maTable As String, NomClasseur As String
Dim nbEnr As Long
maBase = "C:\Users\Lichar\Documents\Base.xlsx"
maTable = "[table$]"
NomClasseur = "C:\Users\Lichar\Documents\Target.xlsx"
maFeuille = "Sheet2"
'Connection to base file
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & maBase & ";" & _
"Extended Properties=""Excel 12.0;HDR=NO;"""
'Requète dans la table Access
Rst.Open "SELECT * FROM " & maTable, Cn
'Connection to target file
Set ExcelCn = New ADODB.Connection
ExcelCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & NomClasseur & ";" & _
"Extended Properties=""Excel 12.0;HDR=NO;"""
'-----------------------------------------
'Create a new sheet and output data
Cn.Execute "SELECT * INTO [Excel 12.0;" & _
"Database=" & NomClasseur & "].[" & maFeuille & "] FROM " & maTable, nbEnr
'-----------------------------------------
'Trying to ouput data in existing sheet
'Cn.Execute "INSERT INTO [sheet$] IN '' [Excel 12.0;" & _
' "Database='" & NomClasseur & "'] SELECT * FROM " & maTable, nbEnr
Rst.Close
Cn.Close
Set ExcelRst = Nothing
Set ExcelCn = Nothing
**EDIT 2 **
I've found a partial solution using INSERT INTO. Here is a working code that takes data from source.xlsx in the table sheet and output it (or append) in target.xlsx in the sheet sheet :
Sub SQLQUERY()
Dim Cn As ADODB.Connection
Dim QUERY_SQL As String
Dim Rst As ADODB.Recordset
Dim ExcelCn As ADODB.Connection
Dim ExcelRst As ADODB.Recordset
SourcePath = "C:\Users\BVR\Documents\Source.xlsx"
TargetPath = "C:\Users\BVR\Documents\Target.xlsx"
CHAINE_HDR = "[Excel 12.0 MACRO;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended Properties='HDR=YES;'] "
Set Cn = New ADODB.Connection
STRCONNECTION = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source='" & SourcePath & "';" & _
"Mode=Read;" & _
"Extended Properties=""Excel 12.0 Macro;"";"
QUERY_SQL = _
"SELECT * FROM [table$] "
Cn.Open STRCONNECTION
Set ExcelCn = New ADODB.Connection
ExcelCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & TargetPath & ";" & _
"Extended Properties=""Excel 12.0;HDR=NO;"""
Cn.Execute "INSERT INTO [sheet$] IN '" & TargetPath & "' 'Excel 12.0;' " & QUERY_SQL
'--- Fermeture connexion ---
Cn.Close
End Sub
I've noticed 2 problems. First If one of my field name contains a "." in it, the code will generate an error stating that INSERT INTO contains an unknown field name. This is problematic.
Second I cannot select only the columns I want. If I "SELECT [F1], [F2] ..." an error will raise stating that there is a circular reference. (I can however select the columns I want using field names)

return csv file as recordset

I have an external program that exports data into CSV files. My users would like to have access to this data through a VBA function in excel. In order to do this, I thought about wrapping the CSV file read into a function that returns a ADODB.Recordset. My code is
Public Function getData(fileName As String) As ADODB.Recordset
Dim path As String
path = "C:\testDir\"
Dim cN As New ADODB.Connection
Dim RS As New ADODB.Recordset
cN.Open ("Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & path & ";" & _
"Extended Properties=""text; HDR=Yes; FMT=Delimited; IMEX=1;""")
RS.ActiveConnection = cN
RS.Source = "select * from " & fileName
Set getData = RS
End Function
I am trying to call this function using
Dim a As ADODB.Recordset
Set a = getData("testFile.csv")
a.Open()
At this point, I get a compile error saying '=' expected. Could someone point me in the right direction on how I should call my function and loop through the data?
Solved it with some tweaks of my own along with input from Tim Williams. Here is the code for anyone else who might need help
Public Function getData(fileName As String) As ADODB.Recordset
Dim path As String
path = "C:\testDir\"
Dim cN As ADODB.Connection
Dim RS As ADODB.Recordset
Set cN = new ADODB.Connection
Set RS = new ADODB.Recordset
cN.Open ("Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & path & ";" & _
"Extended Properties=""text; HDR=Yes; FMT=Delimited; IMEX=1;""")
RS.ActiveConnection = cN
RS.Source = "select * from " & fileName
Set getData = RS
End Function
Now, the function can be called as
Dim a As ADODB.Recordset
Set a = getData("testFile.csv")
a.Open
MsgBox(a.GetString())
a.Close

Resources