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
Related
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") & "')"
I am able to run the code and build a connection but when I am trying to insert data into a MySQL Database from Excel using VBA. It shows '28: Out of Stack space'
I have a code and this is the data here
Name Analyst Method Numsample Condition
AAA AAA AAA 2 ABC
Below is the code I have written,
Dim oConn As ADODB.Connection
Private Sub ConnectDB()
On Error GoTo ErrHandle
Set oConn = New ADODB.Connection
oConn.Open "DRIVER={MySQL ODBC 5.1 Driver};" & _
"SERVER=******************t-1.rds.amazonaws.com;" & _
"DATABASE=worksheet;" & _
"USER=***;" & _
"PASSWORD=****;" & _
"Option=3"
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
ConnectDB
With wsBooks
For rowCursor = 2 To 3
strSQL = "INSERT INTO TestExperiment (Experiment_Name, Experiment_Method, Experiment_Analyst, Experiment_NumSample, Experiment_condition) " & _
"VALUES ('" & esc(.Cells(rowCursor, 1)) & "', " & _
"'" & esc(.Cells(rowCursor, 2)) & "', " & _
"'" & esc(.Cells(rowCursor, 3)) & "', " & _
"'" & esc(.Cells(rowCursor, 4)) & "', " & _
esc(.Cells(rowCursor, 5)) & ")"
rs.Open strSQL, oConn, adOpenDynamic, adLockOptimistic
Next
End With
MsgBox "Connection successful"
ExitHandle:
Set con = Nothing ' RELEASE ALL set OBJECTS
Exit Sub
ErrHandle:
MsgBox Err.Number & ": " & Err.Description
Resume ExitHandle
End Sub
Function esc(txt As String)
esc = Trim(Replace(txt, "'", "\'"))
End Function
Completely new to VBA, just learning code might have some errors. Please help me if you can thanks.
"Out of stack space" is VBA's StackOverflowException. It means you have inadvertently written recursive logic that never escapes the recursion, keeps digging, and digging deeper, ....until the call stack is completely filled and VBA can't track where to return anymore.
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
ConnectDB '<~ recursive call!
With wsBooks
Remove the recursive call, problem solved!
I am using Excel 2013 as a front end application written w/ VBA.
I've linked a XLSX file inside an Access 2013 database in order to use SQL simply for example to read MAX Value of a column of which datas are filtered with a Where Clause.
I cannot understand why a SQL statement for retrieving MAX value does not work whereas the same statement is OK via SQL Querying in Access.
Hereafter VBA code excerpt :
varCnxStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" &
G_sWBookREINVOICingFilePath & ";Mode="
With conXLdb
'*
'.Provider = "Microsoft.ACE.OLEDB.12.0"
'.ConnectionString = "Data Source=" & G_sWBookREINVOICingFilePath & ";"
& "Extended Properties='Excel 12.0;HDR = YES'"
'.Mode = adModeShareExclusive
.Open varCnxStr & adModeShareExclusive
'*
End With
Debug.Print varCnxStr & adModeShareExclusive
strSQL = "SELECT MAX(InvoiceNum) as LastNumInvoice"
strSQL = strSQL & " FROM ReInvoiceDB "
strSQL = strSQL & " WHERE InvoiceNum > " & strYMPrefix_p & "000"
strSQL = strSQL & ";"
Debug.Print strSQL
adoXLrst.Open Source:=strSQL, ActiveConnection:=conXLdb,
CursorType:=adOpenStatic, LockType:=adLockOptimistic, Options:=adCmdText
adoXLrst.MoveFirst
'Set adoXLrst = conXLdb.Execute(strSQL)
HighestStr = adoXLrst![LastNumInvoice]
adoXLrst.Close
strGSFNumber = HighestStr '>> byref returning value
conXLdb.Close
Veloma:
'>>
On Error Resume Next
Set adoXLrst = Nothing
Set conXLdb = Nothing
Exit Sub
'>>
Diso:
Beep
Beep
'>>
strGSFNumber = "ERR"
'>>
sMsg = "pG_getNEXTInvoiceValueXLasDB-ERR ::" & Err.Number & ":: - " &
Err.Description
MsgBox sMsg, vbOKOnly + vbCritical
sRet = sMsg
Resume Veloma
End Sub
It returns Null value in variable HighestStr whereas it should receive a double value ...
Any help or any clue on misfunctionning ?
Regards.
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.
This code requests two input variables from the user and then uses those variables in a query to return data from internal company software. I adapted this code from a macro that someone else at the company uses without issue.
My macro:
Compiles without issue
Experiences run-time error '91': Object variable or With block variable not set
Occurs at With.Selection.ListObject.QueryTable
NOTE: Some details e.g. company name, server, login etc removed!
Option Explicit
Public EN As String
Public REV As String
Dim SearchString As String
Dim SearchString1 As String
Dim SearchString2 As String
Public Sub QueryImport()
EN = Import_Details.EN.Value
REV = Import_Details.REV.Value
Application.ScreenUpdating = False
Unload Import_Details
SearchString = EN
SearchString = EN & Chr(37)
SearchString = EN & Chr(47) & REV & Chr(37)
Sheets("Import").Range("A2").Select
With Selection.ListObject.QueryTable
.Connection = _
"ODBC;DRIVER=SQL Server;SERVER=XXXXXX- XX;UID=XX;PWD=XXXXXX;APP=Microsoft Office 2013;WSID=XXXX;DATABASE=XXX-Live"
.CommandText = _
"SELECT Enquirys_list_with_Parts.""Item No"", Enquirys_list_with_Parts.Description, Enquirys_list_with_Parts.""Part No"", Enquirys_list_with_Parts.Qty, Enquirys_list_with_Parts.Price, Enquirys_list_with_Parts.Total" & Chr(13) & "" & Chr(10) & _
"FROM ""Emax-Live"".dbo.ENQUIRY_LINES_LIST ENQUIRY_LINES_LIST, ""Emax-Live"".dbo.Enquirys_list_with_Parts Enquirys_list_with_Parts, ""Emax-Live"".dbo.Quote_Line_Qty_Drop_list Quote_Line_Qty_Drop_list" & Chr(13) & "" & Chr(10) & _
"WHERE Enquirys_list_with_Parts.""Enquiry No"" = ENQUIRY_LINES_LIST.""Enquiry No"" AND Enquirys_list_with_Parts.""Part No"" = Quote_Line_Qty_Drop_list.Part_No AND ENQUIRY_LINES_LIST.Enquiry_Line_id = Enquirys_list_with_Parts.Enquiry_Line_id AND ((Enquirys_list_with_Parts.""Enquiry No"" Like '" & SearchString1 & "' And Enquirys_list_with_Parts.""Enquiry No"" Like '" & SearchString & "') AND (Quote_Line_Qty_Drop_list.""Quote No"" Like '" & SearchString2 & "'))" & Chr(13) & "" & Chr(10) & _
"ORDER BY Enquirys_list_with_Parts.""Item No""" _
.Refresh BackgroundQuery:=False
End With
Application.ScreenUpdating = True
End Sub
You are trying to reference an object that was never set.
Dim MyQueryTbl as QueryTable
Set MyQueryTbl = Sheet1.QueryTables(1)
Then you can manipulate your MyQueryTbl object.