Connectionstring vba with blank space in dataname get broken - excel

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)

Related

VBA Excel code to retrieve data without opening a file

I'm trying to get data from an excel workbook which is updated every month and the name of the file changes according to the date - I have an instructions page using the today function which gives me the month (this are the cell I'm referencing in "Month")
Problem is, the file I'm opening is very very big, and so this takes over 5 minutes just to start excel and copy the data. Is there anyway to modify my code to get the data without opening the excel file?
This is my code so far -
Sub UploadData()
Dim Model As Workbook
Dim Q As Workbook
Dim rngFX As Range
Dim Month As String
Set Model = ActiveWorkbook
Set Q = Workbooks.Open(Filename:=Sheets("Instructions").Range("$C$29").Value)
Month = ("C" & (Model.Sheets("Instructions").Range("$C$23")))
With Q
With .Sheets(Month & " Summary")
Set rngFX = .Range("A61:R66")
rngFX.Copy Destination:=Model.Sheets("FOREX Forecast").Range("A3")
End With
End With
Q.Close savechanges:=False
With Model.Sheets("FOREX Forecast").UsedRange
.Value = .Value
End With
End Sub
Edit: I've added a picture of the error I'm getting - When I press debug it highlights this line:
Rs.Open strSQL, strConn
Try
Sub UploadData()
Dim Model As Workbook
Dim Q As Workbook
Dim rngFX As Range
Dim Year As String
Dim Fn As String, wsName As String
Dim strConn As String
Dim strSQL As String
Dim Ws As Worksheet
Dim Rs As Object
Set Model = ActiveWorkbook
Set Ws = Model.Sheets("FOREX Forecast")
Fn = Sheets("Instructions").Range("$C$29").Value
'Set Q = Workbooks.Open(Filename:=Sheets("Instructions").Range("$C$29").Value)
Month = "C" & Model.Sheets("Instructions").Range("$C$23")
wsName = "[" & Month & " Summary" & "$" & "A61:R66 ]"
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & Fn & _
";Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"";"
Set Rs = CreateObject("ADODB.Recordset")
strSQL = "select * from " & wsName
Rs.Open strSQL, strConn
Ws.Range("a3").CopyFromRecordset Rs
Rs.Close
Set Rs = Nothing
End Sub

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)

Open Connection and Recordset objects to use SQL for sheet to sheet data movement

I am trying to open Connection and Recordset to use SQL to move data between worksheets within the open workbook. To be clear all the data source sheets are open in the current workbook that I am trying to copy data from and to a different worksheet within the same open workbook.
I have used this code with different inputs to copy data from closed workbooks into the current workbook without error.
The error I am getting is the
"[Microsoft][ODBC Device Manager] Data source name not found and no
default driver specified"
.
The error occurs here:
objRecordSet.Open strSQL, objConnection, 0, 1, 1
The debugger says:
objConnection.Open is <Expression not defined in context>
objConnection.Open : <Expression not defined in context> : Empty : UserForm1.cbPrepareUpload_Click
objConnection : "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=F:\Temp04\Test.xlsm;Mode=Share Deny None;Jet OLEDB:System database="";Jet OLEDB:Registry Path="";Jet OLEDB:Database Password="";Jet OLEDB:Engine Type=35;Jet OLEDB:Database Locking Mode=0;Jet OL"
The environment is Windows 7 64 bit, Office 2010, 32 bit.
I have been agitating the little grey cells over this all day. I have tried to boil this down to the basics but now I am stuck.
Any ideas would help. Thanks, CraigM
Here is the code.
======================================================
Private Sub cbPrepareUpload_Click()
Dim HaveHeader As Boolean
Dim UseHeaderRow As Boolean
Dim i As Long
Dim RowToTest As Long
Dim mySheet As String
Dim shName As String
Dim sh As Worksheet
Dim strConnect As String
Dim strSourceRange As String
Dim strSource As String
Dim strSourceFile As String
Dim strSourceSheet As String
Dim strSQL As String
Dim strTarget As String
Dim objConnection As ADODB.Connection
Dim objRecordSet As ADODB.Recordset
Dim wksName As Worksheet
Set objConnection = New ADODB.Connection
Set objRecordSet = New ADODB.Recordset
strSourceFile = "F:\Temp04\Pricing.xlsx"
strSourceSheet = "Pricing"
strSQL = "SELECT * FROM [Sheet$3] & ;"
HaveHeader = True
UseHeaderRow = True
strSource = "Pricing"
strTarget = "BF_Upload"
For Each wksName In Sheets
If wksName.Name = strTarget Or wksName.Name Like strTarget & "*" Then i = i + 1
Next
If i = 0 Then
Else
Worksheets(strTarget).Activate
ActiveSheet.Name = strTarget & "-" & (i + 1)
End If
Worksheets.Add(Before:=Worksheets(Worksheets.Count)).Name = strTarget
ActiveSheet.Name = strTarget
Sheets(strTarget).Move Before:=Sheets(1)
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes"";"
objConnection.Open strConnect
objRecordSet.Open strSQL, objConnection, 0, 1, 1
Sheets(strSource).Cells(2, 1).CopyFromRecordset objRecordSet
objRecordSet.Close
objConnection.Close
Worksheets(strTarget).Activate
End Sub
Is the "strConnect" parameter intentionally commented out in objConnection.Open 'strConnect Uncomment that parameter and things will hopefully work
edit: also strSQL = "SELECT * FROM [Sheet$3] & ;" is wrong. It should be strSQL = "SELECT * FROM [Sheet3$];" (the $ sign was in the wrong place and there was a stray & symbol in there too)

VBA import two txt files in the same workbook

Is there a way to import two txt files in the same workbook?
I can import one txt file easily with
ActiveSheet.QueryTables.Add(Connection:= _
However whenever I add another it just ignores the first txt file.
Many thanks
Does it ignore the first text file or does it overwrite it if ActiveSheet doesn't change?
You could explicitly specify the Sheet(s) before the .Add method(s) or, if you wanted both imports on the same sheet, there is a Destination:= parameter which allows you to specify a starting Range. A reference can be found here.
If you want to load both Text Files in the same sheet, you can try using ADO.
Something like:
Sub conscious()
Dim con As ADODB.Connection, rec As ADODB.Recordset
Set con = New ADODB.Connection: Set rec = New ADODB.Recordset
Dim datasource As String, txtfiles As Variant _
, txt1 As String, txt2 As String
txtfiles = Application.GetOpenFilename(FileFilter:="CSV Files, *.csv", _
MultiSelect:=True)
datasource = Left(txtfiles(1), InStrRev(txtfiles(1), "\"))
txt1 = "[" & Dir(txtfiles(1)) & "]"
txt2 = "[" & Dir(txtfiles(2)) & "]"
Dim sconnect As String
sconnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & datasource & _
";Extended Properties=""Text;HDR=YES;FMT=Delimited(,)"";"
con.Open sconnect
Dim sqlstr As String
sqlstr = "SELECT * FROM " & txt1 & _
"UNION ALL SELECT * FROM " & txt2
rec.Open sqlstr, con, adOpenStatic, adLockReadOnly
With Sheets("Sheet1")
Dim lrow As Long
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
If lrow > 1 Then .Range("A2:J" & lrow).ClearContents
.Range("A2").CopyFromRecordset rec
End With
Application.ScreenUpdating = True
rec.Close: con.Close
Set rec = Nothing: Set con = Nothing
End Sub
Basically this prompts you to select files.
I used a CSV file as sample. Adjust to suit.
You can select as many files, but this handles the first 2 files only.
If you need to handle more, you'll have to loop through the selected files. HTH

How can make user-defined-function with ADO connection

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.

Resources