First, sorry if my English is not that good; I am a trainee in software development and still learning English.
I made a virtual machine on vSphere with Oracle 19c and Windows Server 2016 64 bit and made an Excel file with macros on this machine. This Excel file is for our Customer to create invoices based on data from the Oracle database. Now our Customer should not perform on his server later when our software and database is delivered, instead he should do what he is doing on an external client which is maybe on the same network.
That is where the Problem starts, I copied the file on my laptop and changed the connection string the "HOST=..." part with the IP-Address from the VM. When I start the Sub a box appears with the message: [Microsoft][ODBC Driver Manager] The Datasourcename was not found, and no default driver specified.
Thank you for your help.
Private Sub Cmd1_Click()
'Variablen deklaration
Dim dbConnection As ADODB.Connection
Dim recordSet As ADODB.recordSet
Dim conString As String
Dim ipAddress As String
Dim port As String
Dim userId As String
Dim password As String
Dim driver As String
Dim dateFrom As String
Dim dateTo As String
Dim Query As String
Dim Lastrow1 As Long
Dim Lastrow2 As Long
'Vorhandene Daten löschen vor dem neuschreiben
Lastrow1 = ThisWorkbook.Sheets("Lagergeld").Range("B" &
Rows.Count).End(xlDown).Row
ThisWorkbook.Sheets("Lagergeld").Range("B3:H" & Lastrow1).Clear
Lastrow2 = ThisWorkbook.Sheets("Dienstleistungen").Range("B" &
Rows.Count).End(xlDown).Row
ThisWorkbook.Sheets("Dienstleistungen").Range("B3:H" & Lastrow2).Clear
Set dbConnection = New ADODB.Connection
' Variables are in a table in the same workbook
userId = Worksheets("Stammdaten").Range("Q4").Value
password = Worksheets("Stammdaten").Range("Q5").Value
ipAddress = Worksheets("Stammdaten").Range("Q6").Value '10.10.10.120
port = Worksheets("Stammdaten").Range("Q7").Value '1521
driver = Worksheets("Stammdaten").Range("Q8").Value ' {Oracle in
OraDB19Home1} tried several like {Microsoft ODBC for Oracle} and others
conString = "Driver=" & driver & ";" & _
"CONNECTSTRING=(DESCRIPTION=" & _
"(ADDRESS=(PROTOCOL=TCP)" & _
"(HOST=" & ipAddress & ")(Port=" & port & "))" & _
"(CONNECT_DATA=(SERVICE_NAME=prod.world)));" & _
"user id=" & userId & ";password=" & password & ";)"
dbConnection.Open (conString)
dateFrom = Worksheets("Auswahl").Range("B12").Value
dateTo = Worksheets("Auswahl").Range("C12").Value
dateFrom = dateFrom & " 00:00:00"
dateTo = dateTo & " 23:59:59"
'Lagergeld
', VasStfCarrierFamilyTypes vscft
Query = " SELECT TO_CHAR(vsf.CreationTime, 'DD.MM.YYYY'), vscf.Name,
vscf.ReferenceHeight *" & _
" vscfh.Factor, vsf.TaxAttribute1, vsf.TaxAttribute2, vsf.Quantity,
vsf.TaxPoint " & _
" FROM VasStorageFee vsf, VasStfCarrierFamily vscf,
VasStfCarrierFamilyHeight vscfh" & _
" WHERE 1 = 1 " & _
" AND vsf.CreationTime >= TO_DATE('" & dateFrom & "', 'DD-MM-YYYY
HH24:MI:SS') " & _
" AND vsf.CreationTime <= TO_DATE('" & dateTo & "', 'DD-MM-YYYY
HH24:MI:SS')" & _
" AND vsf.OwnerCode = '" & Modul1.GetOwnerCode & "'" & _
" AND vsf.CarrierFamily = vscf.ID " & _
" AND vsf.EffectiveHeight = vscfh.ID " & _
" ORDER BY vsf.CreationTime ASC"
Set recordSet = dbConnection.Execute(Query)
ThisWorkbook.Sheets("Lagergeld").Activate
ThisWorkbook.Sheets("Lagergeld").Range("B3").CopyFromRecordset recordSet
ThisWorkbook.Sheets("Lagergeld").Range("B3").NumberFormat = "dd.mm.yyyy"
recordSet.Close
'Dienstleistungen
Query2 = " SELECT TO_CHAR(vsf.CreationTime, 'DD.MM.YYYY'), va.Description,
vsf.CarrierCode," & _
" vsf.MessageText, vsf.ArticleCode, vsf.Quantity, vsf.Taxpoint " &
_
" FROM VasServiceFee vsf, VasActivity va" & _
" WHERE 1 = 1" & _
" AND vsf.CreationTime >= TO_DATE('" & dateFrom & "', 'DD-MM-YYYY
HH24:MI:SS') " & _
" AND vsf.CreationTime <= TO_DATE('" & dateTo & "', 'DD-MM-YYYY
HH24:MI:SS')" & _
" AND vsf.OwnerCode = '" & Modul1.GetOwnerCode & "'" & _
" AND vsf.Activity = va.ID " & _
" ORDER BY vsf.CreationTime ASC"
Set recordSet = dbConnection.Execute(Query2)
ThisWorkbook.Sheets("Dienstleistungen").Range("B3").CopyFromRecordset
recordSet
ThisWorkbook.Sheets("Dienstleistungen").Range("B3").NumberFormat =
"dd.mm.yyyy"
recordSet.Close
dbConnection.Close
End Sub
solution was found, thanks to Eliton who made a comment on another issue. I have now installed the correct driver and adjusted the tnsnames.ora and the environment variables. With sqlplus and the ODBC - Manager from Microsoft I was able to connect successfully.
the only thing that was wrong was my connectionString
It has to be:
conString = "Driver={Oracle in instantclient_19_6}; DBQ=prod.world; PUID=myUser;" & _
"Pwd=myPassword"
I am running a database in Access from within Excel VBA, using data from excel. When I use number as entry, say 12, on the field ClientID, it appends to the database from excel, even though the cell in which the field value is formatted as text and the data type of the CliendID field is set to TEXT(255).
When I change the value to "123ABC" it shows the message "Syntax error (missing operator) in query expression '123ABC'."
When I change the value to "ABC123" it shows the error message: "No value given for one or more required parameters."
I don't have much experience in SQL and have no clue why is this happening, one solution would be to change the clientID to numbers, but a lot of existing regiters I have are already alphanumeric.
The code is writen in excel vba.
Any help muchly appreciated.
Edit:
Sub CreateTables()
On Error GoTo ErrHandle
Dim strpath As String, constr As String
Dim objAccess As Object
Dim conn As Object
strpath = Worksheets("Sheet1").Range("strpathClients")
' CONNECT TO DATABASE '
constr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strpath & ";"
Set conn = CreateObject("ADODB.Connection")
conn.Open constr
conn.Execute "CREATE TABLE Clients (" _
& " ClientID TEXT(255)," _
& " ClientName TEXT(255)," _
& " Address TEXT(255)," _
& " Notes TEXT(255)," _
& " DateCreated DATETIME" _
& ");"
conn.Execute "CREATE TABLE Orders (" _
& " OrderID AUTOINCREMENT," _
& " ClientID TEXT(255)," _
& " Item TEXT(255)," _
& " Price DOUBLE," _
& " OrderDate DATETIME," _
& " Notes TEXT(255)" _
& ");"
' CLOSE CONNECTION '
conn.Close
Set conn = Nothing
MsgBox "Successfully created Clients and Orders tables!", vbInformation
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical
Exit Sub
End Sub
Sub ActionQueriesAPPEND()
On Error GoTo ErrHandle
Dim strpath As String, constr As String
Dim conn As Object
strpath = Worksheets("Sheet1").Range("strpathClients")
' OPEN CONNECTION '
constr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strpath & ";"
Set conn = CreateObject("ADODB.Connection")
conn.Open constr
'MsgBox Worksheets(1).Range("A2")
' APPEND QUERY '
conn.Execute "INSERT INTO Clients (ClientID, ClientName)" _
& " VALUES (" & Worksheets(1).Range("A2") & ", '" &
Worksheets(1).Range("B2") & "');"
conn.Execute "INSERT INTO Orders (ClientID, Item, Price)" _
& " VALUES (" & Worksheets(1).Range("A2") & ", " _
& "'" & Worksheets(1).Range("C2") & "', " _
& Worksheets(1).Range("D2") & ");"
' CLOSE CONNECTION '
conn.Close
Set conn = Nothing
MsgBox "Successfully updated database!", vbInformation
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical
Range("d24") = Err.Description
Exit Sub
conn.Execute "INSERT INTO Clients (ClientID, ClientName)" _
& " VALUES (" & Worksheets(1).Range("A2") & ", '" &
Worksheets(1).Range("B2") & "');"
missing single quotes around the value for ClientId
conn.Execute "INSERT INTO Clients (ClientID, ClientName)" _
& " VALUES ('" & Worksheets(1).Range("A2") & "', '" &
Worksheets(1).Range("B2") & "')"
Hello: I've had success with a long SQL (Oracle) as the Command Text in an OLEDB Data Connection that I entered manually. I then had success entering the SQL via VBA (because I need it to update based on a changing Item List), and only running the first part of the union query as a test.
However, when I made this last change adding a 2nd piece to the union query and making the strQuery command include three separate query strings, it's now throwing me an error at this line of the code below: .CommandText = StrQueryAll
StrQueryAll = StrQueryBegin & StrQueryAZ & StrQueryCO & StrQueryEnd
With ActiveWorkbook.Connections("connection_name").OLEDBConnection
.CommandText = StrQueryAll
.Refresh
End With
Below is the entire code with the actual sql removed. Is there an issue with the code for the sql too long? Or maybe another issue, but it's indirectly saying there's an error? Maybe it doesn't like strQueryAll command? I can do one big sql string with adding on strings with the continuation limitation, but thought it might be cleaner breaking up the sqls.
Thanks for your help!
Private Sub Refresh_Data()
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim ConnectionString As String
Dim StrQueryAll As String
Dim StrQueryBegin As String
Dim StrQueryAZ As String
Dim StrQueryCO As String
Dim StrQueryCA As String
Dim StrQueryEnd As String
Dim Item_List As String
Dim wksItemList As Worksheet
Dim wksDataTable As Worksheet
Dim rngItems As Range
Dim rngDatatbl As Range
Dim myMSG As String
'Dim pt As PivotTable
myString = "Refreshing Tables - Please Wait"
Application.StatusBar = myString
'With Application
'.EnableEvents = False
'.ScreenUpdating = False
'End With
Set wksItemList = Worksheets("Items")
Set rngItems = wksItemList.Range("E4")
Set wksDataTable = Worksheets("data")
Set rngDatatbl = wksDataTable.Range("A3")
Item_List = rngItems.Value
StrQueryBegin = "SELECT " & Chr(13) & "" & Chr(10) & _
..... more sql....
.... next sql string ....
StrQueryAZ = " -- **** AZ ****" & Chr(13) & "" & Chr(10) & _
" select" & Chr(13) & "" & Chr(10) & _
..... more sql....
.... next sql string ....
StrQueryCO = Chr(13) & "" & Chr(10) & " UNION " & Chr(13) & "" & Chr(10) & _
" -- **** CO SYS ****" & Chr(13) & "" & Chr(10) & _
" select " & Chr(13) & "" & Chr(10) & _
..... more sql....
.... next sql string ....
StrQueryEnd = " ) " & Chr(13) & "" & Chr(10) & _
" ORDER BY " & Chr(13) & "" & Chr(10) & _
" ITEM_NBR, WHS " & Chr(13) & "" & Chr(10)
Debug.Print StrQueryBegin & StrQueryAZ & StrQueryCO & StrQueryEnd
StrQueryAll = StrQueryBegin & StrQueryAZ & StrQueryCO & StrQueryEnd
With ActiveWorkbook.Connections("connection_name").OLEDBConnection
.CommandText = StrQueryAll
.Refresh
End With
After doing more searching and tests, the problem is that the total CommandText characters has exceeded the allowable 32,767 chars.
user1274820: In a way, you were right where you needed to see the whole code. The sql is so long because of the way our tables are setup and the sql length is a necessary evil. I'll be looking into other options to run this.
SOLVED. Solution at bottom!
Hopefully you brainiacs can help me out as I've apparently reached the limit of my programming capabilities.
I am looking for a way to write a VBA sub which duplicates another VBA Sub, but replace the name and another input. The case in details:
I am trying to build an Excel template for the organization, which will allow the users to inport/export data to/from Access databases (.accdb), as the end-users reluctance towards using real databases (as opposed to excel lists) apparently lies in their inability to extract/submit the data to/from Excel, where they are comfortable working with the data.
The challenge is, that users who don't know how to link to Access, for sure don't know anything about VBA code. Hence, I have created a worksheet from which the users selects a database using a file-path, table, password, set filters, define where to copy/insert datasets, fields to import etc. A Macro then handles the rest.
However, I want to create a macro which allows the user to create additional database links. As it is right now, this would require the user to open VBE and copy two macros and change one line of code... but that is a recipe for disaster. So how can I add a button to the sheet that copies the code I have written and rename the macro?
... I was considering if using a function, but cannot get my head around how that should Work.
Does it make sense? Any ideas/ experiences? Is there a completely different way around it that I haven't considered?
I'd really appreciate your inputs - even if this turns out to be impossible.
Edit:
Macro Man, you asked for the code - it's rather long due to all the user input fields, so I was trying to save you Guys for it since the code in and of itself is working fine...
Sub GetData1()
' Click on Tools, References and select
' the Microsoft ActiveX Data Objects 2.0 Library
Dim DBFullName As String
Dim Connect As String, Source As String
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset
Dim Col As Integer
Dim DBInfoLocation As Range
Dim PW As String
Dim WSforData As String
Dim CellforData As String
Dim FieldList As Integer
'******************************
'Enter location for Database conectivity details below:
'******************************
Set DBInfoLocation = ActiveWorkbook.Sheets("DBLinks").Range("C15:I21")
FieldList = ActiveWorkbook.Sheets("DBLinks").Range("P1").Value
'******************************
' Define data location
WSforData = DBInfoLocation.Rows(4).Columns(1).Value
CellforData = DBInfoLocation.Rows(5).Columns(1).Value
'Set filters
Dim FilField1, FilField2, FilFieldA, FilFieldB, FilFieldC, FilFieldD, FilFieldE, FilOperator1, FilOperator2, FilOperatorA, FilOperatorB, FilOperatorC, FilOperatorD, FilOperatorE, FilAdMth1, FilAdMthA, FilAdMthB, FilAdMthC, FilAdMthD As String
Dim Filtxt1, Filtxt2, FiltxtA, FiltxtB, FiltxtC, FiltxtD, FiltxtE As String
Dim ExtFld1, ExtFld2, ExtFld3, ExtFld4, ExtFld5, ExtFld6, ExtFld7, ExtFld As String
Dim FilCnt, FilCntA As Integer
Dim FilVar1 As String
'Set DB field names
FilField1 = DBInfoLocation.Rows(1).Columns(5).Value
FilField2 = DBInfoLocation.Rows(2).Columns(5).Value
FilFieldA = DBInfoLocation.Rows(3).Columns(5).Value
FilFieldB = DBInfoLocation.Rows(4).Columns(5).Value
FilFieldC = DBInfoLocation.Rows(5).Columns(5).Value
FilFieldD = DBInfoLocation.Rows(6).Columns(5).Value
FilFieldE = DBInfoLocation.Rows(7).Columns(5).Value
'Set filter operators
FilOperator1 = DBInfoLocation.Rows(1).Columns(6).Value
FilOperator2 = DBInfoLocation.Rows(2).Columns(6).Value
FilOperatorA = DBInfoLocation.Rows(3).Columns(6).Value
FilOperatorB = DBInfoLocation.Rows(4).Columns(6).Value
FilOperatorC = DBInfoLocation.Rows(5).Columns(6).Value
FilOperatorD = DBInfoLocation.Rows(6).Columns(6).Value
FilOperatorE = DBInfoLocation.Rows(7).Columns(6).Value
'Run through criteria to find VarType(FilCrit1) (the Dimension data type) for the criteria field and set the appropriate data type for the filter
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(1).Columns(7).Value), CDbl(FilCrit1), IIf((DBInfoLocation.Rows(1).Columns(7).Value = "True" Or DBInfoLocation.Rows(1).Columns(7).Value = "False"), CBool(FilCrit1), IIf(IsDate(DBInfoLocation.Rows(1).Columns(7).Value), CDate(FilCrit1), CStr(FilCrit1))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(2).Columns(7).Value), CDbl(FilCrit2), IIf((DBInfoLocation.Rows(2).Columns(7).Value = "True" Or DBInfoLocation.Rows(2).Columns(7).Value = "False"), CBool(FilCrit2), IIf(IsDate(DBInfoLocation.Rows(2).Columns(7).Value), CDate(FilCrit2), CStr(FilCrit2))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(3).Columns(7).Value), CDbl(FilCrit3), IIf((DBInfoLocation.Rows(3).Columns(7).Value = "True" Or DBInfoLocation.Rows(3).Columns(7).Value = "False"), CBool(FilCrit3), IIf(IsDate(DBInfoLocation.Rows(3).Columns(7).Value), CDate(FilCrit3), CStr(FilCrit3))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(4).Columns(7).Value), CDbl(FilCrit4), IIf((DBInfoLocation.Rows(4).Columns(7).Value = "True" Or DBInfoLocation.Rows(4).Columns(7).Value = "False"), CBool(FilCrit4), IIf(IsDate(DBInfoLocation.Rows(4).Columns(7).Value), CDate(FilCrit4), CStr(FilCrit4))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(5).Columns(7).Value), CDbl(FilCrit5), IIf((DBInfoLocation.Rows(5).Columns(7).Value = "True" Or DBInfoLocation.Rows(5).Columns(7).Value = "False"), CBool(FilCrit5), IIf(IsDate(DBInfoLocation.Rows(5).Columns(7).Value), CDate(FilCrit5), CStr(FilCrit5))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(6).Columns(7).Value), CDbl(FilCrit6), IIf((DBInfoLocation.Rows(6).Columns(7).Value = "True" Or DBInfoLocation.Rows(6).Columns(7).Value = "False"), CBool(FilCrit6), IIf(IsDate(DBInfoLocation.Rows(6).Columns(7).Value), CDate(FilCrit6), CStr(FilCrit6))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(7).Columns(7).Value), CDbl(FilCrit7), IIf((DBInfoLocation.Rows(7).Columns(7).Value = "True" Or DBInfoLocation.Rows(7).Columns(7).Value = "False"), CBool(FilCrit7), IIf(IsDate(DBInfoLocation.Rows(7).Columns(7).Value), CDate(FilCrit7), CStr(FilCrit7))))
'Set Filter criteria
FilCrit1 = DBInfoLocation.Rows(1).Columns(7).Value
FilCrit2 = DBInfoLocation.Rows(2).Columns(7).Value
FilCrit3 = DBInfoLocation.Rows(3).Columns(7).Value
FilCrit4 = DBInfoLocation.Rows(4).Columns(7).Value
FilCrit5 = DBInfoLocation.Rows(5).Columns(7).Value
FilCrit6 = DBInfoLocation.Rows(6).Columns(7).Value
FilCrit7 = DBInfoLocation.Rows(7).Columns(7).Value
'Set additional filter-method
FilAdMth1 = DBInfoLocation.Rows(1).Columns(8).Value
FilAdMthA = DBInfoLocation.Rows(3).Columns(8).Value
FilAdMthB = DBInfoLocation.Rows(4).Columns(8).Value
FilAdMthC = DBInfoLocation.Rows(5).Columns(8).Value
FilAdMthD = DBInfoLocation.Rows(6).Columns(8).Value
'Set which fields to extract
ExtFld1 = DBInfoLocation.Rows(1).Columns(9).Value
ExtFld2 = DBInfoLocation.Rows(2).Columns(9).Value
ExtFld3 = DBInfoLocation.Rows(3).Columns(9).Value
ExtFld4 = DBInfoLocation.Rows(4).Columns(9).Value
ExtFld5 = DBInfoLocation.Rows(5).Columns(9).Value
ExtFld6 = DBInfoLocation.Rows(6).Columns(9).Value
ExtFld7 = DBInfoLocation.Rows(7).Columns(9).Value
'Filter on query
'Only criteria of value type string should have single quotation marks around them
FilCnt = 0
If FilField1 <> "" Then
If VarType(FilCrit1) = vbString Then
Filtxt1 = " WHERE [" & FilField1 & "] " & FilOperator1 & " '" & FilCrit1 & "'"
Else
Filtxt1 = " WHERE [" & FilField1 & "] " & FilOperator1 & " " & FilCrit1
End If
FilCnt = 1
End If
If FilField2 <> "" And FilCnt = 1 Then
If VarType(FilCrit2) = vbString Then
Filtxt2 = " " & FilAdMth1 & " [" & FilField2 & "] " & FilOperator2 & " '" & FilCrit2 & "'"
Else
Filtxt2 = " " & FilAdMth1 & " [" & FilField2 & "] " & FilOperator2 & " " & FilCrit2
End If
FilCnt = 2
End If
'Filter on Dataset
FilCntA = 0
If FilFieldA <> "" Then
If VarType(FilCrit3) = vbString Then
FiltxtA = FilFieldA & " " & FilOperatorA & " '" & FilCrit3 & "'"
Else
FiltxtA = FilFieldA & " " & FilOperatorA & " " & FilCrit3
End If
FilCntA = 1
End If
If FilFieldB <> "" And FilCntA = 1 Then
If VarType(FilCrit4) = vbString Then
FiltxtB = " " & FilAdMthA & " " & FilFieldB & " " & FilOperatorB & " '" & FilCrit4 & "'"
Else
FiltxtB = " " & FilAdMthA & " " & FilFieldB & " " & FilOperatorB & " " & FilCrit4
End If
FilCntA = 2
End If
If FilFieldC <> "" And FilCntA = 2 Then
If VarType(FilCrit5) = vbString Then
FiltxtC = " " & FilAdMthB & " " & FilFieldC & " " & FilOperatorC & " '" & FilCrit5 & "'"
Else
FiltxtC = " " & FilAdMthB & " " & FilFieldC & " " & FilOperatorC & " " & FilCrit5
End If
FilCntA = 3
End If
If FilFieldD <> "" And FilCntA = 3 Then
If VarType(FilCrit6) = vbString Then
FiltxtD = " " & FilAdMthC & " " & FilFieldD & " " & FilOperatorD & " '" & FilCrit6 & "'"
Else
FiltxtD = " " & FilAdMthC & " " & FilFieldD & " " & FilOperatorD & " " & FilCrit6
End If
FilCntA = 4
End If
If FilFieldE <> "" And FilCntA = 4 Then
If VarType(FilCrit7) = vbString Then
FiltxtE = " " & FilAdMthD & " " & FilFieldE & " " & FilOperatorE & " '" & FilCrit7 & "'"
Else
FiltxtE = " " & FilAdMthD & " " & FilFieldE & " " & FilOperatorE & " " & FilCrit7
End If
FilCntA = 5
End If
' Select Fields to Extract
ExtFld = "*"
If ExtFld1 <> "" Then
ExtFld = "[" & ExtFld1 & "]"
End If
If ExtFld2 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "]"
End If
If ExtFld3 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "]"
End If
If ExtFld4 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "],[" & ExtFld4 & "]"
End If
If ExtFld5 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "],[" & ExtFld4 & "],[" & ExtFld5 & "]"
End If
If ExtFld6 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "],[" & ExtFld4 & "],[" & ExtFld5 & "],[" & ExtFld6 & "]"
End If
If ExtFld7 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "],[" & ExtFld4 & "],[" & ExtFld5 & "],[" & ExtFld6 & "],[" & ExtFld7 & "]"
End If
' Database path info
PW = DBInfoLocation.Rows(3).Columns(1).Value
' Your path will be different
DBFullName = DBInfoLocation.Rows(1).Columns(1).Value
DBTable = DBInfoLocation.Rows(2).Columns(1).Value
' Open the connection
Set Connection = New ADODB.Connection
Connect = "Provider=Microsoft.ACE.OLEDB.12.0;"
Connect = Connect & "Data Source=" & DBFullName & ";Jet OLEDB:Database Password=" & PW & ";"
Connection.Open ConnectionString:=Connect
' Create RecordSet & Define data to extract
Set Recordset = New ADODB.Recordset
With Recordset
'Get All Field Names by opening the DB, extracting a recordset, entering the field names and closing the dataset
Source = DBTable
.Open Source:=Source, ActiveConnection:=Connection
For ColH = 0 To Recordset.Fields.Count - 1
ActiveWorkbook.Worksheets("DBLinks").Range("A1").Offset(ColH + 3, FieldList - 1).Cells.Clear
ActiveWorkbook.Worksheets("DBLinks").Range("A1").Offset(ColH + 3, FieldList - 1).Value = Recordset.Fields(ColH).Name
ActiveWorkbook.Worksheets("RangeNames").Range("A1").Offset(ColH + 2, (DBInfoLocation.Rows(1).Columns(2).Value) - 1).Cells.Clear
ActiveWorkbook.Worksheets("RangeNames").Range("A1").Offset(ColH + 2, (DBInfoLocation.Rows(1).Columns(2).Value) - 1).Value = Recordset.Fields(ColH).Name
Next
Set Recordset = Nothing
End With
' Get the recordset, but only extract the field names of those defined in the spreadsheet.
' If no fields have been selected, all fields will be extracted.
Set Connection = New ADODB.Connection
Connect = "Provider=Microsoft.ACE.OLEDB.12.0;"
Connect = Connect & "Data Source=" & DBFullName & ";Jet OLEDB:Database Password=" & PW & ";"
Connection.Open ConnectionString:=Connect
Set Recordset = New ADODB.Recordset
With Recordset
If FilCnt = 0 Then 'No filter
Source = "SELECT " & ExtFld & " FROM " & DBTable
End If
' Filter Data if selected
If FilCnt = 1 Then
Source = "SELECT " & ExtFld & " FROM " & DBTable & Filtxt1
End If
If FilCnt = 2 Then
Source = "SELECT " & ExtFld & " FROM " & DBTable & Filtxt1 & Filtxt2
End If
.Open Source:=Source, ActiveConnection:=Connection
If FilCntA = 1 Then
Recordset.Filter = FiltxtA
End If
If FilCntA = 2 Then
Recordset.Filter = FiltxtA & FiltxtB
End If
If FilCntA = 3 Then
Recordset.Filter = FiltxtA & FiltxtB & FiltxtC
End If
If FilCntA = 4 Then
Recordset.Filter = FiltxtA & FiltxtB & FiltxtC & FiltxtD
End If
If FilCntA = 5 Then
Recordset.Filter = FiltxtA & FiltxtB & FiltxtC & FiltxtD & FiltxtE
End If
'Debug.Print Recordset.Filter
' Clear data
For Col = 0 To Recordset.Fields.Count - 1
If WSforData <> "" Then
ActiveWorkbook.Worksheets(WSforData).Range(CellforData).Offset(0, Col).EntireColumn.Clear
End If
'ActiveWorkbook.Worksheets("DBLinks").Range("A1").Offset(Col + 3, FieldList - 1).Cells.Clear
Next
' Write field names
For Col = 0 To Recordset.Fields.Count - 1
If WSforData <> "" Then
ActiveWorkbook.Worksheets(WSforData).Range(CellforData).Offset(0, Col).Value = Recordset.Fields(Col).Name
End If
Next
' Write recordset
If WSforData <> "" Then
ActiveWorkbook.Worksheets(WSforData).Range(CellforData).Offset(1, 0).CopyFromRecordset Recordset
ActiveWorkbook.Worksheets(WSforData).Columns.AutoFit
End If
End With
' Clear recordset and close connection
Set Recordset = Nothing
Connection.Close
Set Connection = Nothing
End Sub
This piece of the "DBLinks" worksheet is probably also needed for full understanding of the code:
DBLinks user input area for database connectivity
SOLUTION:
I followed the advice to look into VBProject.VBComponents which copied the macro. I created a simple form which asked for the name to use for the macro and the rest of the inputs comes from the relative reference. I will spare you for a full copy of my long and less than graceful code, but the essential of the code are:
In case someone else could benefit from my experience: In the Click-action of the command button on the form:
Private Sub cmdCreateDB_Click()
'Go to Tools, References and add: Microsoft Visual Basic for Applications Extensibility 5.3
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Const DQUOTE = """" ' one " character
Set VBProj = ActiveWorkbook.VBProject
Set VBComp = VBProj.VBComponents("Module1")
Set CodeMod = VBComp.CodeModule
Dim txtDBLinkName As String
txtDBLinkName = Me.txtDBName
With CodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, " Sub " & txtDBLinkName & "()"
LineNum = LineNum + 1
.InsertLines LineNum, " ' Click on Tools, References and select"
LineNum = LineNum + 1
.InsertLines LineNum, " ' the Microsoft ActiveX Data Objects 2.0 Library"
' And then it goes on forever through all the lines of the original code...
' just remember to replace all double quotations with(Without Square brackets):
' [" & DQUOTE & "]
'And it ends up with:
LineNum = LineNum + 1
.InsertLines LineNum, " Set Recordset = Nothing"
LineNum = LineNum + 1
.InsertLines LineNum, " Connection.Close"
LineNum = LineNum + 1
.InsertLines LineNum, " Set Connection = Nothing"
LineNum = LineNum + 1
.InsertLines LineNum, " End Sub"
End With
Unload Me
End Sub
Thank you everyone for your help. - Especially you #findwindow for coming up with the path to a solution.
For the sake of completion, here's how this could be dealt with without metaprogramming.
Problems that boil down to "do the same thing - but..." can often be solved by making the program as generic as possible. All data specific to a single use-case should be passed down from above in a clear manner, allowing the program to be reused.
Let's look at an example of how this could be implemented in order to generate query strings from one or many ranges of varying sizes.
The first step is to group all data that belongs to the concept of a Filter. Since VBA doesn't have object literals, we can use an Array, a Collection or a Type to represent a Filter instead.
Generating the query strings requires distinction between QueryFilters and RecordFilters. Looking at the code, the two variants are similar enough to be handled by a simple Boolean within a single Type.
Option Explicit
Private Type Filter
Field As String
Operator As String
Criteria As Variant
AdditionalMethod As String
ExtractedFields As String
IsQueryFilter As Boolean
FilterString As String
End Type
Now we can use a single variable instead of keeping track of multiple variables to represent a single concept.
One way a Filter can be generated is by using a Range.
' Generates a Filter from a given Range of input data.
Private Function GenerateFilter(ByRef source As Range) As Filter
With GenerateFilter
.Field = CStr(source)
.Operator = CStr(source.Offset(0, 1))
.Criteria = source.Offset(0, 2)
.AdditionalMethod = CStr(source.Offset(0, 3))
.ExtractedFields = CStr(source.Offset(0, 4))
.IsQueryFilter = CBool(source.Offset(0, 5))
.FilterString = GenerateFilterString(GenerateFilter)
End With
End Function
Just as a single concept can be declared as a Type, a group of things can be declared as an Array (or a Collection, Dictionary, ...). This is useful, as it lets us decouple the logic from a specific Range.
' Generates a Filter for each row of a given Range of input data.
Private Function GenerateFilters(ByRef source As Range) As Filter()
Dim filters() As Filter
Dim filterRow As Range
Dim i As Long
ReDim filters(0 To source.Rows.Count)
i = 0
For Each filterRow In source.Rows
filters(i) = GenerateFilter(filterRow)
i = i + 1
Next
GenerateFilters = filters()
End Function
We now have a function that can return an Array of Filters from a given Range - and, as long as the columns are laid down in the right order, the code will work just fine with any Range.
With all of the data in a convenient package, it's easy enough to assemble the FilterString.
' Generates a FilterString for a given Filter.
Private Function GenerateFilterString(ByRef aFilter As Filter) As String
Dim temp As String
temp = " "
With aFilter
If .AdditionalMethod <> "" Then temp = temp & .AdditionalMethod & " "
If .IsQueryFilter Then
temp = temp & "[" & .Field & "]"
Else
temp = temp & .Field
End If
temp = temp & " " & .Operator & " "
If VarType(.Criteria) = vbString Then
temp = temp & "'" & .Criteria & "'"
Else
temp = temp & .Criteria
End If
End With
GenerateFilterString = temp
End Function
The data can then be merged to strings that can be used in queries regardless of how many Filters of either type are present in the specified Range.
' Merges the FilterStrings of Filters that have IsQueryString set as True.
Private Function MergeQueryFilterStrings(ByRef filters() As Filter) As String
Dim temp As String
Dim i As Long
temp = " WHERE"
For i = 0 To UBound(filters)
If filters(i).IsQueryFilter Then temp = temp & filters(i).FilterString
Next
MergeQueryFilterStrings = temp
End Function
' Merges the FilterStrings of Filters that have IsQueryString set as False.
Private Function MergeRecordFilterStrings(ByRef filters() As Filter) As String
Dim temp As String
Dim i As Long
For i = 0 To UBound(filters)
If Not filters(i).IsQueryFilter Then _
temp = temp & filters(i).FilterString
Next
MergeRecordFilterStrings = temp
End Function
' Merges the ExtractedFields of all Filters.
Private Function MergeExtractedFields(ByRef filters() As Filter) As String
Dim temp As String
Dim i As Long
temp = ""
For i = 0 To UBound(filters)
If filters(i).ExtractedFields <> "" Then _
temp = temp & "[" & filters(i).ExtractedFields & "],"
Next
If temp = "" Then
temp = "*"
Else
temp = Left(temp, Len(temp) - 1) ' Remove dangling comma.
End If
MergeExtractedFields = temp
End Function
With all of that done, we can finally plug a single Range in and get the generated strings out. It would be trivial to change filterRange or generate Filters from multiple Ranges.
Public Sub TestStringGeneration()
Dim filters() As Filter
Dim filterRange As Range
Set filterRange = Range("A1:A10")
filters = GenerateFilters(filterRange)
Debug.Print MergeQueryFilterStrings(filters)
Debug.Print MergeRecordFilterStrings(filters)
Debug.Print MergeExtractedFields(filters)
End Sub
TL;DR
Split code to reusable Functions & Subs
Favor sending data as arguments
Avoid hard-coding
Group data that represent a single concept
Use Arrays or other data structures over multiple variables
I am trying to import and sort data from a large excel report into a new file using Excel 2007 VBA. I have come up with two methods so far for doing this:
Have Excel actually open the file (code below), gather all data into arrays and output the arrays onto new sheets in the same file and save/close it.
Public Sub GetData()
Dim FilePath As String
FilePath = "D:\File_Test.xlsx"
Workbooks.OpenText Filename:=FilePath, FieldInfo:=Array(Array(2, 2))
ActiveWorkbook.Sheets(1).Select
End Sub
Use ADO to get all data out of the closed workbook, import the whole datasheet into an array (code below) and sort data from there and then output data into a new workbook and save/close that.
Private Sub PopArray() 'Uses ADO to populate an array that will be used to sort data
Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
Dim Getvalue, SourceRange, SourceFile, dbConnectionString As String
SourceFile = "D:\File_Test.xlsx"
SourceRange = "B1:Z180000"
dbConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=No"";"
Set dbConnection = New ADODB.Connection
dbConnection.Open dbConnectionString 'open the database connection
Set rs = dbConnection.Execute("SELECT * FROM [" & SourceRange & "]")
Arr = rs.GetRows
UpBound = UBound(Arr, 2)
rs.Close
End Sub
The test file used has about 65000 records to sort through (about a third of what I will end up using it for). I was kind of disappointed when the ADO version only performed marginally better than the open worksheet (~44 seconds vs ~40 seconds run time). I was wondering if there is some way to improve the ADO import method (or a completely different method - ExecuteExcel4Macro maybe? - if there is one) that would boost my speed. The only thing I could think of was that I am using "B1:Z180000" as my SourceRange as a maximum range that is then truncated by setting Arr = rs.GetRows to accurately reflect the total number of records. If that is what is causing the slow down, I'm not sure how I would go about finding how many rows are in the sheet.
Edit - I am using Range("A1:A" & i) = (Array) to insert data into the new worksheet.
This answer might not be what you are looking for but I still felt compelled to post it based on your side note [...] or a completely different method ]...].
Here, I am working with files of 200MB (and more) each which are merely text files including delimiters. I do not load them into Excel anymore. I also had the problem that Excel was too slow and needs to load the entire file. Yet, Excel is very fast at opening these files using the Open method:
Open strFileNameAndPath For Input Access Read Lock Read As #intPointer
In this case Excel is not loading the entire file but merely reading it line by line. So, Excel can already process the data (forward it) and then grab the next line of data. Like this Excel does not neet the memory to load 200MB.
With this method I am then loading the data in a locally installed SQL which transfers the data directly to our DWH (also SQL). To speed up the transfer using the above mething and getting the data fast into the SQL server I am transferring the data in chunks of 1000 rows each. The string variable in Excel can hold up to 2 billion characters. So, there is not problem there.
One might wonder why I am not simply using SSIS if I am already using a local installation of SQL. Yet, the problem is that I am not the one loading all these files anymore. Using Excel to generate this "import tool" allowed me to forward these tools to others, who are now uploading all these files for me. Giving all of them access to SSIS was not an option nor the possibility of using a destined network drive where one could place these files and SSIS would automatically load them (ever 10+ minutes or so).
In the end my code looks something like this.
Set conRCServer = New ADODB.Connection
conRCServer.ConnectionString = "PROVIDER=SQLOLEDB; " _
& "DATA SOURCE=" & Ref.Range("C2").Value2 & ";" _
& "INITIAL CATALOG=" & Ref.Range("C4").Value & ";" _
& "Integrated Security=SSPI "
On Error GoTo SQL_ConnectionError
conRCServer.Open
On Error GoTo 0
'Save the name of the current file
strCurrentFile = ActiveWorkbook.Name
'Prepare a dialog box for the user to pick a file and show it
' ...if no file has been selected then exit
' ...otherwise parse the selection into it's path and the name of the file
Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Extracts", "*.csv")
Application.FileDialog(msoFileDialogOpen).Title = "Select ONE Extract to import..."
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
If intChoice <> 0 Then
strFileToPatch = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
Else
Exit Sub
End If
'Open the Extract for import and close it afterwards
intPointer = FreeFile()
Open strFileNameAndPath For Input Access Read Lock Read As #intPointer
intCounter = 0
strSQL = vbNullString
Do Until EOF(intPointer)
Line Input #intPointer, strLine
If Left(strLine, 4) = """###" Then Exit Sub
'*********************************************************************
'** Starting a new SQL command
'*********************************************************************
If intCounter = 0 Then
Set rstResult = New ADODB.Recordset
strSQL = "set nocount on; "
strSQL = strSQL & "insert into dbo.tblTMP "
strSQL = strSQL & "values "
End If
'*********************************************************************
'** Transcribe the current line into SQL
'*********************************************************************
varArray = Split(strLine, ",")
strSQL = strSQL & " (" & varArray(0) & ", " & varArray(1) & ", N'" & varArray(2) & "', "
strSQL = strSQL & " N'" & varArray(3) & "', N'" & varArray(4) & "', N'" & varArray(5) & "', "
strSQL = strSQL & " N'" & varArray(6) & "', " & varArray(8) & ", N'" & varArray(9) & "', "
strSQL = strSQL & " N'" & varArray(10) & "', N'" & varArray(11) & "', N'" & varArray(12) & "', "
strSQL = strSQL & " N'" & varArray(13) & "', N'" & varArray(14) & "', N'" & varArray(15) & "' ), "
'*********************************************************************
'** Execute the SQL command in bulks of 1.000
'*********************************************************************
If intCounter >= 1000 Then
strSQL = Mid(strSQL, 1, Len(strSQL) - 2)
rstResult.ActiveConnection = conRCServer
On Error GoTo SQL_StatementError
rstResult.Open strSQL
On Error GoTo 0
If Not rstResult.EOF And Not rstResult.BOF Then
strErrorMessage = "The server returned the following error message(s):" & Chr(10)
While Not rstResult.EOF And Not rstResult.BOF
strErrorMessage = Chr(10) & strErrorMessage & rstResult.Fields(0).Value
rstResult.MoveNext
Wend
MsgBox strErrorMessage & Chr(10) & Chr(10) & "Aborting..."
Exit Sub
End If
End If
intCounter = intCounter + 1
Loop
Close intPointer
Set rstResult = Nothing
Exit Sub
SQL_ConnectionError:
Y = MsgBox("Couldn't connect to the server. Please make sure that you have a working internet connection. " & _
"Do you want me to prepare an error-email?", 52, "Problems connecting to Server...")
If Y = 6 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Ref.Range("C7").Value2
.CC = Ref.Range("C8").Value2
.Subject = "Problems connecting to database '" & Ref.Range("C4").Value & "' on server '" & Ref.Range("C2").Value & "'"
.HTMLBody = "<span style=""font-size:10px"">---Automatically generated Error-Email---" & _
"</span><br><br>Error report from the file '" & _
"<span style=""color:blue"">" & ActiveWorkbook.Name & _
"</span>' located and saved on '<span style=""color:blue"">" & _
ActiveWorkbook.Path & "</span>'.<br>" & _
"Excel is not able to establish a connection to the server. Technical data to follow." & "<br><br>" & _
"Computer Name: <span style=""color:green;"">" & Environ("COMPUTERNAME") & "</span><br>" & _
"Logged in as: <span style=""color:green;"">" & Environ("USERDOMAIN") & "/" & Environ("USERNAME") & "</span><br>" & _
"Domain Server: <span style=""color:green;"">" & Environ("LOGONSERVER") & "</span><br>" & _
"User DNS Domain: <span style=""color:green;"">" & Environ("USERDNSDOMAIN") & "</span><br>" & _
"Operating System: <span style=""color:green;"">" & Environ("OS") & "</span><br>" & _
"Excel Version: <span style=""color:green;"">" & Application.Version & "</span><br>" & _
"<br><span style=""font-size:10px""><br>" & _
"<br><br>---Automatically generated Error-Email---"
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Exit Sub
SQL_StatementError:
Y = MsgBox("There seems to be a problem with the SQL Syntax in the programming. " & _
"May I send an error-email to development team?", 52, "Problems with the coding...")
If Y = 6 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Ref.Range("C8").Value2
'.CC = ""
.Subject = "Problems with the SQL Syntax in file '" & ActiveWorkbook.Name & "'."
.HTMLBody = "<span style=""font-size:10px"">" & _
"---Automatically generated Error-Email---" & _
"</span><br><br>" & _
"Error report from the file '" & _
"<span style=""color:blue"">" & _
ActiveWorkbook.Name & _
"</span>" & _
"' located and saved on '" & _
"<span style=""color:blue"">" & _
ActiveWorkbook.Path & _
"</span>" & _
"'.<br>" & _
"It seems that there is a problem with the SQL-Code within trying to upload an extract to the server." & _
"SQL-Code causing the problems:" & _
"<br><br><span style=""color:green;"">" & _
strSQL & _
"</span><br><br><span style=""font-size:10px"">" & _
"---Automatically generated Error-Email---"
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Exit Sub
End Sub
i think that #Mr. Mascaro is right the easiest way to past your data from a Recordset into a spreadsheet is:
Private Sub PopArray()
.....
Set rs = dbConnection.Execute("SELECT * FROM [" & SourceRange & "]")
'' This is faster
Range("A1").CopyFromRecordset rs
''Arr = rs.GetRows
End Sub
but if you still want to use Arrays you could try this:
Sub ArrayTest
'' Array for Test
Dim aSingleArray As Variant
Dim aMultiArray as Variant
'' Set values
aSingleArray = Array("A","B","C","D","E")
aMultiArray = Array(aSingleArray, aSingleArray)
'' You can drop data from the Array using 'Resize'
'' Btw, your Array must be transpose to use this :P
Range("A1").Resize( _
UBound(aMultiArray(0), 1) + 1, _
UBound(aMultiArray, 1) + 1) = Application.Transpose(aMultiArray)
End Sub