I need to get values from Sheet1 Column A (number of rows changes every day - can be more than 7,000) and Sheet2 Column B (also dynamic - changes every day), put those values from the columns into an array in STRING type (can be two arrays as long as I can use them in the query) and use the array in vba query WHERE ... IN ('array') to be run in MS-SQL server.
I've tried different ways to get the values into an array but have failed as many solutions offered need to use Array AS Variant when I need String type (to work in the query). One method that kind of worked was getting the values (comma separated) into one cell in another sheet and using that cell.value in the query. But that method is only good for total rows of 3000 or less. I've tried adding more - like cell2.value, cell3.value, but I would get errors (ex)if there were no values available for cell3.value. Please help.
Sub GetData()
Dim oConn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim fld As ADODB.Field
Dim mssql As String
Dim row As Integer
Dim Col As Integer
Dim WB As ThisWorkbook
'============THIS IS THE PART I NEED HELP WITH ======================
Dim strArray() As String 'TRYING TO GET VALUES FROM COLUMN AS ARRAY
Dim TotalRows As Long
Dim i As Long
TotalRows = Rows(Rows.count).End(xlUp).row
ReDim strArray(1 To TotalRows)
For i = 1 To TotalRows
strArray(i) = Cells(i, 1).Value & "','" 'TRYING TO INCLUDE COMMAS BETWEEN VALUES
Next
'===========================================================================
Set WB = ThisWorkbook
Application.ScreenUpdating = False
Set oConn = New ADODB.Connection 'NEED TO CONNECT TO SQL SERVER TO RUN QUERY
Set rs = New ADODB.Recordset
mssql = "SELECT Order.ID, Order.OrderDate, Order.Account" _
& " FROM dbo.tbl_Order" _
& " WHERE Order.ID IN ('" & strArray() & "0'")" '<=== THIS IS WHERE I NEED TO INSERT STRING ARRAY
oConn.ConnectionString = "driver={SQL Server};" & _
"server=SERVER01;authenticateduser = TRUE;database=DATABASE01"
oConn.ConnectionTimeout = 30
oConn.Open
rs.Open mssql, oConn
If rs.EOF Then
MsgBox "No matching records found."
rs.Close
oConn.Close
Exit Sub
End If
' ===clear data in columns in worksheet as new values are copied over old ones
' ===this part is working fine
Worksheets("Sheet3").Range("A:P").ClearContents
' START WRITING DATA TO SHEET3
row = 5
Col = 1
For Each fld In rs.Fields
Sheet3.Cells(row, Col).Value = fld.Name
Col = Col + 1
Next
rs.MoveFirst
row = row + 1
Do While Not rs.EOF
Col = 1
For Each fld In rs.Fields
Sheet1.Cells(row, Col).Value = fld
Col = Col + 1
Next
row = row + 1
rs.MoveNext
Loop
rs.Close
oConn.Close
End Sub
You don't want to build an array but rather a string with the values you need. I stripped down your code to illustrate how this works:
Sub GetData()
Dim values As String
Dim mssql As String
Dim TotalRows As Long
Dim i As Long
TotalRows = Rows(Rows.Count).End(xlUp).row
For i = 1 To TotalRows
values = values & "'" & Cells(i, 1).Value & "',"
Next
values = Mid(values, 1, Len(values) - 1)
mssql = "SELECT Order.ID, Order.OrderDate, Order.Account " & _
"FROM dbo.tbl_Order " & _
"WHERE Order.ID IN (" & values & ")"
MsgBox mssql
End Sub
Get Zero-Based From Column
If you can use an array of strings (don't know SQL), for column A you could e.g. use:
Dim strArray() As String: strArray = getZeroBasedFromColumn(Range("A2"))
If you have to use a string then you will have to do:
Dim strArray As String
strArray = "'" & Join(getZeroBasedFromColumn(Range("A2")), "','") & "'"
and use strArray without the parentheses.
Qualify the first cell range (A2) appropriately e.g. WB.Worksheets("Sheet1").Range("A2").
Both solutions use the following function.
The Code
Function getZeroBasedFromColumn( _
FirstCell As Range) _
As Variant
Const ProcName As String = "getZeroBasedFromColumn"
On Error GoTo clearError
If Not FirstCell Is Nothing Then
Dim rg As Range
Set rg = FirstCell.Resize(FirstCell.Worksheet.Rows.Count - FirstCell.Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If Not rg Is Nothing Then
Set rg = FirstCell.Resize(rg.Row - FirstCell.Row + 1)
Dim rCount As Long: rCount = rg.Rows.Count
Dim Data As Variant
If rCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
Else
Data = rg.Value
End If
Dim arr() As String: ReDim arr(0 To rCount - 1)
Dim i As Long
For i = 1 To rCount
arr(i - 1) = CStr(Data(i, 1))
Next i
getZeroBasedFromColumn = arr
End If
End If
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
Sub getZeroBasedFromColumnTEST()
Dim arr() As String: arr = getZeroBasedFromColumn(Range("A1"))
End Sub
An alternative (if you have the necessary database permissions) is to create a temporary table and use a JOIN in place of the WHERE IN().
Option Explicit
Sub GetData()
' get list of order numbers from Col A Sheet1 and COl B Sheet2
Dim wb As Workbook, wsOut As Worksheet
Dim rngA As Range, rngB As Range
Dim ar, ar1, ar2, iLastRow As Long, SQL As String
Dim i As Long, n As Long, id As String
Set wb = ThisWorkbook
Set wsOut = wb.Sheets("Sheet3")
' copy sheet1 Column A into array ar1
iLastRow = Sheet1.Cells(Rows.Count, "A").End(xlUp).row
Set rngA = Sheet1.Range("A1:A" & iLastRow)
If rngA.Rows.Count = 1 Then
ar1 = Array(0, rngA.Cells(1, 1).Value2)
Else
ar1 = Application.Transpose(rngA.Value2)
End If
'Debug.Print "A", LBound(ar1), UBound(ar1)
' copy sheet2 column B into array ar2
iLastRow = Sheet2.Cells(Rows.Count, "B").End(xlUp).row
Set rngB = Sheet2.Range("B1:B" & iLastRow)
If rngB.Rows.Count = 1 Then
ar2 = Array(0, rngB.Cells(1, 1).Value2)
Else
ar2 = Application.Transpose(rngB.Value2)
End If
'Debug.Print "B", LBound(ar2), UBound(ar2)
' connect to DB and create temporary table
Dim oConn As New ADODB.Connection
With oConn
.ConnectionString = "driver={SQL Server};" & _
"server=SERVER01;authenticateduser = TRUE;database=DATABASE01"
.ConnectionTimeout = 30
.Open
End With
oConn.Execute "CREATE TABLE #tmp (ID varchar(20) NOT NULL,PRIMARY KEY (ID ASC))"
' prepare insert query
SQL = "INSERT INTO #tmp (ID) VALUES (?)"
Dim cmd As New ADODB.Command
With cmd
.CommandType = adCmdText
.ActiveConnection = oConn
.CommandText = SQL
.Parameters.Append .CreateParameter("p1", adVarChar, adParamInput, 20)
End With
' insert array values into temp table
Dim t0 As Single: t0 = Timer
For Each ar In Array(ar1, ar2)
oConn.BeginTrans
For i = 1 To UBound(ar)
id = Trim(ar(i))
If Len(id) > 0 Then
cmd.Execute n, id
End If
Next
oConn.CommitTrans
'Debug.Print i - 1 & " Inserted"
Next
n = oConn.Execute("SELECT COUNT(*) FROM #tmp")(0)
'Debug.Print n & " records inserted into #tmp in " & Format(Timer - t0, "#.0 secs")
' select records using join as where filter
SQL = " SELECT Ord.ID, Ord.OrderDate, Ord.Account" _
& " FROM [tbl_Order] as Ord" _
& " JOIN #tmp ON Ord.ID = #tmp.ID"
' output result
Dim rs As New ADODB.Recordset
Set rs = oConn.Execute(SQL, n)
wsOut.Range("A:P").ClearContents
' header
Dim fld, cell As Range
Set cell = wsOut.Cells(5, 1)
For Each fld In rs.Fields
cell = fld.Name
Set cell = cell.Offset(0, 1)
Next
' data
wsOut.Cells(6, 1).CopyFromRecordset rs
oConn.Close
' end
n = wsOut.Cells(Rows.Count, 1).End(xlUp).row - 6
MsgBox n & " rows witten in " & Format(Timer - t0, "0.00 secs")
End Sub
I have created a user form in excel to save my records in a sheets like sheet1.
But after few days working with this UserForm, it is now goes slower, because of heavy data saving in sheet1.
Now I want to save all records to a database and want to keep clean my sheet1.
So I can work on my UserForm easily or without any delay. Also wants updates my record by calling it via serial numbers.
but I don't want to keep any record in my sheet1.
my little code is below: -
Sub cmdAdd_Click()
On Error GoTo ErrOccured
BlnVal = 0
If BlnVal = 0 Then Exit Sub
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim txtId, txtName, GenderValue, txtLocation, txtCNum, txtEAddr, txtRemarks
Dim iCnt As Integer
iCnt = fn_LastRow(Sheets("Data")) + 1
If frmData.obMale = True Then
GenderValue = "Male"
Else
GenderValue = "Female"
End If
With Sheets("Data")
.Cells(iCnt, 1) = iCnt - 1
.Cells(iCnt, 2) = frmData.txtName
.Cells(iCnt, 3) = GenderValue
.Cells(iCnt, 4) = frmData.txtLocation.Value
.Cells(iCnt, 5) = frmData.txtEAddr
.Cells(iCnt, 6) = frmData.txtCNum
.Cells(iCnt, 7) = frmData.txtRemarks
.Columns("A:G").Columns.AutoFit
.Range("A1:G1").Font.Bold = True
.Range("A1:G1").LineStyle = xlDash
End If
End With
Dim IdVal As Integer
IdVal = fn_LastRow(Sheets("Data"))
frmData.txtId = IdVal
ErrOccured:
'TurnOn screen updating
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
I will always be grateful to you.
Then, please try the next way. I will try creating of the necessary DB, table and fields using Excel VBA, too:
Copy the next piece of code which will create an empty DB, on the path you want:
Sub CreateEmptyDB()
Dim strPath As String, objAccess As Object
strPath = "C:\Your path\testDB"
Set objAccess = CreateObject("Access.Application")
Call objAccess.NewCurrentDatabase(strPath)
objAccess.Quit
End Sub
Programatically create the necessary table with its fields (`Start Date' added only to see how this type of data is handled...):
Sub createTableFields()
'It needs a reference to `Microsoft ActiveX Data Objects 2.x Library` (x = 2 to 9)
Dim Catalog As Object, cn As ADODB.Connection
Dim dbPath As String, scn As String, strTable As String
dbPath = "C:\Teste VBA Excel\testAccess\testDB.accdb"
strTable = "MySpecial_Table"
scn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath & ";"
Set Catalog = CreateObject("ADOX.Catalog")
Set cn = New ADODB.Connection
With cn
.Open scn
.Execute "CREATE TABLE " & strTable & " ([Name] text(255) WITH " & _
"Compression, " & "[Gender] text(255) WITH Compression, " & _
"[Location] text(255) WITH Compression, " & _
"[Address] text(255) WITH Compression, " & _
"[Number] number, " & _
"[Remarks] text(255) WITH Compression, " & _
"[Start Date] datetime)"
End With
cn.Close
End Sub
Add records to the newly created DB/Table:
Sub FillDataInDB()
'It needs a reference to `Microsoft ActiveX Data Objects 2.x Library` (x = 2 to 9)
Dim AccessDB As String, strTable As String, sql As String
Dim con As ADODB.Connection, rs As ADODB.Recordset, lastNo As Long
AccessDB = "C:\Teste VBA Excel\testAccess\testDB.accdb"
strTable = "MySpecial_Table"
Set con = CreateObject("ADODB.connection")
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessDB
sql = "SELECT * FROM " & strTable
Set rs = CreateObject("ADODB.Recordset")
rs.CursorType = 1 'adOpenKeyset on early binding
rs.LockType = 3 'adLockOptimistic on early binding
rs.Open sql, con
If rs.RecordCount = 0 Then
lastNo = 0 'when no records in the table
Else
rs.MoveLast: lastNo = rs("Number") 'the last recorded value
End If
rs.AddNew
rs("Name") = "Test name" 'frmData.txtName
rs("Gender") = "Test gender" 'GenderValue
rs("Location") = "Test Location" 'frmData.txtLocation.Value
rs("Address") = "Test Address" 'frmData.txtEAddr
rs("Number") = IIf(lastNo = 0, 100, lastNo + 1) 'auto incrementing against the last value
'but starting from 100
'you can use frmData.txtCNum
rs("Remarks") = "Remarkable table..." 'frmData.txtRemarks
rs("Start Date") = Date
rs.Update
rs.Close: con.Close
Set rs = Nothing: Set con = Nothing
End Sub
Run the first two pieces of code in consecutive order (only once) and then start playing with the third one...
You can read the newly created DB Table (returning in an Excel sheet) in this way:
Sub ADO_Connection_ReadTable()
Dim conn As New Connection, rec As New Recordset, sh As Worksheet
Dim AccessDB As String, connString, query As String, strTable As String
AccessDB = "C:\Teste VBA Excel\testAccess\testDB.accdb"
strTable = "MySpecial_Table"
Set sh = ActiveSheet 'use here the sheet you want
connString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessDB
conn.Open connString
query = "SELECT * from " & strTable & ";"
rec.Open query, conn
'return in the sheet
sh.cells.ClearContents
'getting data from the recordset if any and returning some in columns A:B:
If (rec.RecordCount <> 0) Then
Do While Not rec.EOF
With sh.Range("A" & sh.cells(Rows.count, 1).End(xlUp).row).Offset(1, 0)
.Value2 = rec.fields(0).Value
.Offset(0, 1).Value2 = rec.fields(3)
End With
rec.MoveNext
Loop
End If
rec.Close: conn.Close
End Sub
You can use a query to return specific data according to a specific table field. You can find plenty of examples on the internet.
I tried also showing how to handle an automate recording for the 'Number' field. Of course, if you are able to keep track of it in a different way, you can record it as you need/wont.
Please, test the above code(s) and send some feedback. You can use the DB path as a Private constant at the module level and much other ways to optimize the code. It is just a minimum workable solution only showing the way... :)
if i have these 2 tables:
is there some sort of excel vba code (using ADO) that could acheive these desired results which could utilise any query i put in the SQL sheet?
Here's some VBA code that allows you to read an Excel range using the text SQL driver. It's quite a complex example, but I'm guessing that you came here because you're a fairly advanced user with a more complex problem than the examples we see on other sites.
Before I post the code in full, here's the original 'sample usage' comment in the core function, FetchXLRecordSet:
' Sample usage:
'
' Set rst = FetchXLRecordSet(SQL, "TableAccountLookup", "TableCashMap")
'
' Where the query uses two named ranges, "TableAccountLookup" and "TableCashMap"
' as shown in this SQL statement:
'
' SELECT
' B.Legal_Entity_Name, B.Status,
' SUM(A.USD_Settled) As Settled_Cash
' FROM
' [TableAccountLookup] AS A,
' [TableCashMap] AS B
' WHERE
' A.Account IS NOT NULL
' AND B.Cash_Account IS NOT NULL
' AND A.Account = B.Cash_Account
' GROUP BY
' B.Legal_Entity_Name,
' B.Status
It's clunky, forcing you to name the tables (or list the range addresses in full) when you run the query, but it simplifies the code.
Option Explicit
Option Private Module
' ADODB data retrieval functions to support Excel
' Online reference for connection strings:
' http://www.connectionstrings.com/oracle#p15
' Online reference for ADO objects & properties:
' http://msdn.microsoft.com/en-us/library/ms678086(v=VS.85).aspx
' External dependencies:
' Scripting - C:\Program files\scrrun.dll
' ADO - C:\Program files\Common\system\ado\msado27.tlb
Private m_strTempFolder As String
Private m_strConXL As String
Private m_objConnXL As ADODB.Connection
Public Property Get XLConnection() As ADODB.Connection
On Error GoTo ErrSub
' The Excel database drivers have memory problems so we use the text driver
' to read csv files in a temporary folder. We populate these files from
' ranges specified for use as tables by the FetchXLRecordSet() function.
Dim objFSO As Scripting.FileSystemObject
Set objFSO = New Scripting.FileSystemObject
Set m_objConnXL = New ADODB.Connection
' Specify and clear a temporary folder:
m_strTempFolder = objFSO.GetSpecialFolder(2).ShortPath
If Right(m_strTempFolder, 1) <> "\" Then
m_strTempFolder = m_strTempFolder & "\"
End If
m_strTempFolder = m_strTempFolder & "XLSQL"
Application.DisplayAlerts = False
If objFSO.FolderExists(m_strTempFolder) Then
objFSO.DeleteFolder m_strTempFolder
End If
If Not objFSO.FolderExists(m_strTempFolder) Then
objFSO.CreateFolder m_strTempFolder
End If
If Right(m_strTempFolder, 1) <> "\" Then
m_strTempFolder = m_strTempFolder & "\"
End If
' JET OLEDB text driver connection string:
' Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\txtFilesFolder\;Extended Properties="text;HDR=Yes;FMT=Delimited";
' ODBC text driver connection string:
' Driver={Microsoft Text Driver (*.txt; *.csv)};Dbq=c:\txtFilesFolder\;Extensions=asc,csv,tab,txt;
m_strConXL = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & m_strTempFolder & ";"
m_strConXL = m_strConXL & "Extended Properties=" & Chr(34) & "text;HDR=Yes;IMEX=1" & Chr(34) & ";"
With m_objConnXL
.CursorLocation = adUseClient
.CommandTimeout = 90
.ConnectionString = m_strConXL
.Mode = adModeRead
End With
If m_objConnXL.State = adStateClosed Then
Application.StatusBar = "Connecting to the local Excel tables"
m_objConnXL.Open
End If
Set XLConnection = m_objConnXL
ExitSub:
Application.StatusBar = False
Exit Property
ErrSub:
MsgPopup "Error connecting to the Excel local data. Please contact Application Support.", vbCritical + vbApplicationModal, "Database connection failure!", 10
Resume ErrEnd
' Resume ExitSub
ErrEnd:
End ' Terminal error. Halt.
End Property
Public Sub CloseConnections()
On Error Resume Next
Set m_objConnXL = Nothing
End Sub
Public Function FetchXLRecordSet(ByVal SQL As String, ParamArray TableNames()) As ADODB.Recordset
' This allows you to retrieve data from Excel ranges using SQL. You
' need to pass additional parameters specifying each range you're using as a table
' so that the these ranges can be saved as csv files in the 'XLSQL' temporary folder
' Note that your query must use the 'table' naming conventions required by the Excel
' database drivers: http://www.connectionstrings.com/excel#20
On Error Resume Next
Dim i As Integer
Dim iFrom As Integer
Dim strRange As String
Dim j As Integer
Dim k As Integer
If IsEmpty(TableNames) Then
TableNames = Array("")
End If
If InStr(TypeName(TableNames), "(") < 1 Then
TableNames = Array(TableNames)
End If
Set FetchXLRecordSet = New ADODB.Recordset
With FetchXLRecordSet
.CacheSize = 8
Set .ActiveConnection = XLConnection
iFrom = InStr(8, SQL, "From", vbTextCompare) + 4
For i = LBound(TableNames) To UBound(TableNames)
strRange = ""
strRange = TableNames(i)
If strRange = "0" Or strRange = "" Then
j = InStr(SQL, "FROM") + 4
j = InStr(j, SQL, "[")
k = InStr(j, SQL, "]")
strRange = Mid(SQL, j + 1, k - j - 1)
End If
RangeToFile strRange
SQL = Left(SQL, iFrom) & Replace(SQL, strRange, strRange & ".csv", iFrom + 1, 1)
SQL = Replace(SQL, "$.csv", ".csv")
SQL = Replace(SQL, ".csv$", ".csv")
SQL = Replace(SQL, ".csv.csv", ".csv")
Next i
.Open SQL, , adOpenStatic, , adCmdText + adAsyncFetch
i = 0
Do While .State > 1
i = (i + 1) Mod 3
Application.StatusBar = "Connecting to the database" & String(i, ".")
Sleep 250
Loop
End With
Application.StatusBar = False
End Function
Public Function ReadRangeSQL(SQL_Range As Excel.Range) As String
' Read a range into a string.
' Each row is delimited with a carriage-return and a line break.
' Empty cells are concatenated into the string as 'Tabs' of four spaces.
'NH Feb 2018: you cannot return more than 32767 chars into a range.
Dim i As Integer
Dim j As Integer
Dim arrCells As Variant
Dim arrRows() As String
Dim arrRowX() As String
Dim strRow As String
Dim boolIndent As Boolean
Const SPACE As String * 1 = " "
Const SPACE4 As String * 4 = " "
Const MAX_LEN As Long = 32767
arrCells = SQL_Range.Value2
If InStr(TypeName(arrCells), "(") Then
ReDim arrRows(LBound(arrCells, 1) To UBound(arrCells, 1))
ReDim arrRowX(LBound(arrCells, 2) To UBound(arrCells, 2))
For i = LBound(arrCells, 1) To UBound(arrCells, 1) - 1
boolIndent = True
For j = LBound(arrCells, 2) To UBound(arrCells, 2)
If isError(arrCells(i, j)) Then
SQL_Range(i, j).Calculate
End If
If Not isError(arrCells(i, j)) Then
arrRowX(j) = arrCells(i, j)
Else
arrRowX(j) = vbNullString
End If
If boolIndent And arrRowX(j) = "" Then
arrRowX(j) = SPACE4
Else
boolIndent = False
End If
Next j
arrRows(i) = Join(arrRowX, SPACE)
If Len(Trim$(arrRows(i))) = 0 Then
arrRows(i) = vbNullString
Else
arrRows(i) = RTrim$(Join(arrRowX, SPACE))
End If
Next i
Erase arrCells
Erase arrRowX
ReadRangeSQL = Join(arrRows, vbCrLf)
Erase arrRows
ReadRangeSQL = Replace(ReadRangeSQL, vbCrLf & vbCrLf, vbCrLf)
Else
ReadRangeSQL = CStr(arrCells)
End If
If Len(ReadRangeSQL) > MAX_LEN Then
' Trip terminating spaces from each row:
Do While InStr(1, ReadRangeSQL, SPACE & vbCrLf, vbBinaryCompare) > 0
ReadRangeSQL = Replace(ReadRangeSQL, SPACE & vbCrLf, vbCrLf)
Loop
End If
If Len(ReadRangeSQL) > MAX_LEN Then
' Reduce the 'tab' size to 2 selectively, after each row's indentation
arrRows = Split(ReadRangeSQL, vbCrLf)
For i = LBound(arrRows) To UBound(arrRows)
If Len(arrRows(i)) > 16 Then
If InStr(12, arrRows(i), SPACE4) > 0 Then
arrRows(i) = Left$(arrRows(i), 12) & Replace(Right$(arrRows(i), Len(arrRows(i)) - 12), SPACE4, SPACE & SPACE)
End If
End If
Next i
ReadRangeSQL = Join(arrRows, vbCrLf)
Erase arrRows
End If
If Len(ReadRangeSQL) > MAX_LEN Then
' Reduce the 'tab' size to 2 indiscriminately. This will make your SQL illegible:
Do While InStr(1, ReadRangeSQL, SPACE4, vbBinaryCompare) > 0
ReadRangeSQL = Replace(ReadRangeSQL, SPACE4, SPACE & SPACE)
Loop
End If
End Function
Public Sub RangeToFile(ByRef strRange As String)
' Output a range to a csv file in a temporary folder created by the XLConnection function
' strRange specifies a range in the current workbook using the 'table' naming conventions
' specified for Excel OLEDB database drivers: http://www.connectionstrings.com/excel#20
' The first row of the range is assumed to be a set of column names.
On Error Resume Next
Dim objFSO As Scripting.FileSystemObject
Dim rng As Excel.Range
Dim strFile As String
Dim arrData As Variant
Dim iRow As Long
Dim jCol As Long
Dim strData As String
Dim strLine As String
strRange = Replace(strRange, "[", "")
strRange = Replace(strRange, "]", "")
If Right(strRange, 1) = "$" Then
strRange = Replace(strRange, "$", "")
Set rng = ThisWorkbook.Worksheets(strRange).UsedRange
Else
strRange = Replace(strRange, "$", "")
Set rng = Range(strRange)
If rng Is Nothing Then
Set rng = ThisWorkbook.Worksheets(strRange).UsedRange
End If
End If
If rng Is Nothing Then
Exit Sub
End If
Set objFSO = New Scripting.FileSystemObject
strFile = m_strTempFolder & strRange & ".csv"
If objFSO.FileExists(strFile) Then
objFSO.DeleteFile strFile, True
End If
If objFSO.FileExists(strFile) Then
Exit Sub
End If
arrData = rng.Value2
With objFSO.OpenTextFile(strFile, ForWriting, True)
' Header row:
strLine = ""
strData = ""
iRow = LBound(arrData, 1)
For jCol = LBound(arrData, 2) To UBound(arrData, 2)
strData = arrData(iRow, jCol)
strData = Replace(strData, Chr(34), Chr(39))
strData = Replace(strData, Chr(10), " ")
strData = Replace(strData, Chr(13), " ")
strData = strData & ","
strLine = strLine & strData
Next jCol
strLine = Left(strLine, Len(strLine) - 1) ' Trim trailing comma
If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
.WriteLine strLine
End If
' Rest of the data
For iRow = LBound(arrData, 1) + 1 To UBound(arrData, 1)
strLine = ""
strData = ""
For jCol = LBound(arrData, 2) To UBound(arrData, 2)
If IsError(arrData(iRow, jCol)) Then
strData = "#ERROR"
Else
strData = arrData(iRow, jCol)
strData = Replace(strData, Chr(34), Chr(39))
strData = Replace(strData, Chr(10), " ")
strData = Replace(strData, Chr(13), " ")
strData = Replace(strData, Chr(9), " ")
strData = Trim(strData)
End If
strData = Chr(34) & strData & Chr(34) & "," ' Quotes to coerce all values to text
strLine = strLine & strData
Next jCol
strLine = Left(strLine, Len(strLine) - 1) ' Trim trailing comma
If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
.WriteLine strLine
End If
Next iRow
.Close
End With ' textstream object from objFSO.OpenTextFile
Set objFSO = Nothing
Erase arrData
Set rng = Nothing
End Sub
And finally, Writing a Recordset to a Range - the code would be trivial if it wasn't for all the errors you have to handle:
Public Sub RecordsetToRange(rngTarget As Excel.Range, objRecordset As ADODB.Recordset, Optional FieldList As Variant, Optional ShowFieldNames As Boolean = False, Optional Orientation As Excel.XlRowCol = xlRows)
' Write an ADO Recordset to an Excel range in a single 'hit' to the sheet
' Calling function is responsible for setting the record pointer (must not be EOF!)
' The target range is resized automatically to the dimensions of the array, with the top left cell used as the start point.
On Error Resume Next
Dim OutputArray As Variant
Dim i As Integer
Dim iCol As Integer
Dim iRow As Integer
Dim varField As Variant
If objRecordset Is Nothing Then
Exit Sub
End If
If objRecordset.State <> 1 Then
Exit Sub
End If
If objRecordset.BOF And objRecordset.EOF Then
Exit Sub
End If
If Orientation = xlColumns Then
If IsEmpty(FieldList) Or IsMissing(FieldList) Then
OutputArray = objRecordset.GetRows
Else
OutputArray = objRecordset.GetRows(Fields:=FieldList)
End If
Else
If IsEmpty(FieldList) Or IsMissing(FieldList) Then
OutputArray = ArrayTranspose(objRecordset.GetRows)
Else
OutputArray = ArrayTranspose(objRecordset.GetRows(Fields:=FieldList))
End If
End If
ArrayToRange rngTarget, OutputArray
If ShowFieldNames Then
If Orientation = xlColumns Then
ReDim OutputArray(LBound(OutputArray, 1) To UBound(OutputArray, 1), 1 To 1)
iRow = LBound(OutputArray, 1)
If IsEmpty(FieldList) Or IsMissing(FieldList) Then
For i = 0 To objRecordset.Fields.Count - 1
If i > UBound(OutputArray, 1) Then
Exit For
End If
OutputArray(iRow + i, 1) = objRecordset.Fields(i).Name
Next i
Else
If InStr(TypeName(FieldList), "(") < 1 Then
FieldList = Array(FieldList)
End If
i = 0
For Each varField In FieldList
OutputArray(iRow + i, 1) = CStr(varField)
i = i = 1
Next
End If 'IsEmpty(FieldList) Or IsMissing(FieldList)
ArrayToRange rngTarget.Cells(1, 0), OutputArray
Else
ReDim OutputArray(1 To 1, LBound(OutputArray, 2) To UBound(OutputArray, 2))
iCol = LBound(OutputArray, 2)
If IsEmpty(FieldList) Or IsMissing(FieldList) Then
For i = 0 To objRecordset.Fields.Count - 1
If i > UBound(OutputArray, 2) Then
Exit For
End If
OutputArray(1, iCol + i) = objRecordset.Fields(i).Name
Next i
Else
If InStr(TypeName(FieldList), "(") < 1 Then
FieldList = Array(FieldList)
End If
i = 0
For Each varField In FieldList
OutputArray(1, iCol + i) = CStr(varField)
i = i = 1
Next
End If ' IsEmpty(FieldList) Or IsMissing(FieldList)
ArrayToRange rngTarget.Cells(0, 1), OutputArray
End If ' Orientation = xlColumns
End If 'ShowFieldNames
Erase OutputArray
End Sub
Public Function ArrayTranspose(InputArray As Variant) As Variant
' Transpose InputArray.
' Returns InputArray unchanged if it is not a 2-Dimensional Variant(x,y)
Dim iRow As Long
Dim iCol As Long
Dim iRowCount As Long
Dim iColCount As Long
Dim boolNoRows As Boolean
Dim BoolNoCols As Boolean
Dim OutputArray As Variant
If IsEmpty(InputArray) Then
ArrayTranspose = InputArray
Exit Function
End If
If InStr(1, TypeName(InputArray), "(") < 1 Then
ArrayTranspose = InputArray
Exit Function
End If
' Check that we can read the array's dimensions:
On Error Resume Next
Err.Clear
iRowCount = 0
iRowCount = UBound(InputArray, 1)
If Err.Number <> 0 Then
boolNoRows = True
End If
Err.Clear
Err.Clear
iColCount = 0
iColCount = UBound(InputArray, 2)
If Err.Number <> 0 Then
BoolNoCols = True
End If
Err.Clear
If boolNoRows Then
' ALL arrays have a defined Ubound(MyArray, 1)!
' This variant's dimensions cannot be determined
OutputArray = InputArray
ElseIf BoolNoCols Then
' It's a vector. Strictly speaking, a vector cannot be 'transposed', as
' calling the ordinal a 'row' or a 'column' is arbitrary or meaningless.
' But... By convention, Excel users regard a vector as an array of 1 to n
' rows and 1 column. So we'll 'transpose' it into a Variant(1 to 1, 1 to n)
ReDim OutputArray(1 To 1, LBound(InputArray, 1) To UBound(InputArray, 1))
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
OutputArray(1, iRow) = InputArray(iRow)
Next iRow
Else
ReDim OutputArray(LBound(InputArray, 2) To UBound(InputArray, 2), LBound(InputArray, 1) To UBound(InputArray, 1))
If IsEmpty(OutputArray) Then
ArrayTranspose = InputArray
Exit Function
End If
If InStr(1, TypeName(OutputArray), "(") < 1 Then
ArrayTranspose = InputArray
Exit Function
End If
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
OutputArray(iCol, iRow) = InputArray(iRow, iCol)
Next iCol
Next iRow
End If
ExitFunction:
ArrayTranspose = OutputArray
Erase OutputArray
End Function
Postscript: Running SQL on Excel 'Table' Objects
For completeness, here's the code for a barebones 'read Excel Table objects with SQL' function that handles all the text-file hacking in the background.
I'm posting it now, a while after my original answer went up, because everyone's using the rich 'table' object for tabulated data in Excel:
' Run a JOIN query on your tables, and write the field names and data to Sheet1:
SaveTable "Table1"
SaveTable "Table2"
SQL= SQL & "SELECT * "
SQL= SQL & " FROM Table1 "
SQL= SQL & " LEFT JOIN Table2 "
SQL= SQL & " ON Table1.Client = Table2.Client"
RunSQL SQL, Sheet1.Range("A1")
...And the full listing (give or take a couple of functions in the previous code dump) is:
Public Function RunSQL(SQL As String, TargetRange As Excel.Range, Optional DataSetName As String)
' Run SQL against table files in the local ExcelSQL folder and write the results to a target range
' The full implementation of ExcelSQL provides a fully-featured UI on a control sheet
' This is a cut-down version which runs everything automatically, without audit & error-reporting
' SQL can be read from ranges using the ReadRangeSQL function
' If no target range object is passed in, and a Data set name is specified, the recordset will be
' saved as [DataSetName].csv in the local Excel SQL folder for subsequent SQL queries
' If no target range is specified and no Data set name specified, returns the recordet object
Dim rst As ADODB.Recordset
If Left(SQL, 4) = "SQL_" Then
SQL = ReadRangeSQL(ThisWorkbook.Names(SQL).RefersToRange)
End If
Set rst = FetchTextRecordset(SQL)
If TargetRange Is Nothing Then
If DataSetName = "" Then
Set RunSQL = rst
Else
RecordsetToCSV rst, DataSetName, , , , , , , False
Set rst = Nothing
End If
Else
RecordsetToRange rst, TargetRange, True
Set rst = Nothing
End If
End Function
Public Function FetchTextRecordset(SQL As String) As ADODB.Recordset
' Fetch records from the saved text files in the Temp SQL Folder:
On Error Resume Next
Dim i As Integer
Dim iFrom As Integer
If InStr(1, connText, "IMEX=1", vbTextCompare) > 0 Then SetSchema
Set FetchTextRecordset = New ADODB.Recordset
With FetchTextRecordset
.CacheSize = 8
Set .ActiveConnection = connText
On Error GoTo ERR_ADO
.Open SQL, , adOpenStatic, , adCmdText + adAsyncFetch
i = 0
Do While .State > 1
i = (i + 1) Mod 3
Application.StatusBar = "Waiting for data" & String(i, ".")
Application.Wait Now + (0.25 / 24 / 3600)
Loop
End With
Application.StatusBar = False
ExitSub:
Exit Function
ERR_ADO:
Dim strMsg
strMsg = vbCrLf & vbCrLf & "If this is a 'file' error, someone's got one of the source data files open: try again in a few minutes." & vbCrLf & vbCrLf & "Otherwise, please make a note of this error message and contact the developer, or " & SUPPORT & "."
If Verbose Then
MsgBox "Error &H" & Hex(Err.Number) & ": " & Err.Description & strMsg, vbCritical + vbMsgBoxHelpButton, "Data retrieval error:", Err.HelpFile, Err.HelpContext
End If
Resume ExitSub
Exit Function
' Try this if SQL is too big to debug in the immediate window:
' FSO.OpenTextFile("C:\Temp\SQL.txt",ForWriting,True).Write SQL
' Shell "Notepad.exe C:\Temp\SQL.txt", vbNormalFocus
'Resume
End Function
Private Property Get connText() As ADODB.Connection
On Error GoTo ErrSub
Dim strTempFolder
If m_objConnText Is Nothing Then
Set m_objConnText = New ADODB.Connection
strTempFolder = TempSQLFolder ' this will test whether the folder permits SQL READ operations
Application.DisplayAlerts = False
' MS-Access ACE OLEDB Provider
m_strConnText = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & strTempFolder & Chr(34) & ";Persist Security Info=True;"
m_strConnText = m_strConnText & "Extended Properties=" & Chr(34) & "text;CharacterSet=UNICODE;HDR=Yes;HDR=Yes;IMEX=1;MaxScanRows=1" & Chr(34) & ";"
End If
If Not m_objConnText Is Nothing Then
With m_objConnText
If .State = adStateClosed Then
Application.StatusBar = "Connecting to the local Excel tables"
.CursorLocation = adUseClient
.CommandTimeout = 90
.ConnectionString = m_strConnText
.Mode = adModeRead
.Open
End If
End With
If m_objConnText.State = adStateClosed Then
Set m_objConnText = Nothing
End If
End If
Set connText = m_objConnText
ExitSub:
Application.StatusBar = False
Exit Property
ErrSub:
MsgBox "Error connecting to the Excel local data. Please contact " & SUPPORT & ".", vbCritical + vbApplicationModal, "Database connection failure!", 10
Resume ErrEnd
' Resume ExitSub
ErrEnd:
End ' Terminal error. Halt.
End Property
Public Sub CloseConnections()
On Error Resume Next
Set m_objConnText = Nothing
End Sub
Public Function TempSQLFolder() As String
Application.Volatile False
' Location of temporary table files used by the SQL text data functions
' Also runs a background process to clear out files over 7 days old
' The best location is a named subfolder in the user's temp folder. The
' user local 'temp' folder is discoverable on all Windows systems using
' GetObject("Scripting.FileSystemObject").GetSpecialFolder(2).ShortPath
' and will usually be C:\Users\[User Name]\AppData\Local\Temp
' Dependencies:
' Object Property FSO (Returns Scripting.FilesystemObject)
'
Dim strCMD As String
Dim strMsg As String
Dim strNamedFolder As String
Static strTempFolder As String ' Cache it
Dim iRetry As Integer
Dim i As Long
' If we've already found a usable temp folder, use the static value
' without querying the file system and testing write privileges again:
If strTempFolder <> "" Then
TempSQLFolder = strTempFolder
Exit Function
End If
On Error Resume Next
strTempFolder = GetObject("Scripting.FileSystemObject").GetSpecialFolder(2).ShortPath
If Right(strTempFolder, 1) <> "\" Then
strTempFolder = strTempFolder & "\"
End If
strTempFolder = strTempFolder & "XLSQL"
If Not FSO.FolderExists(strTempFolder) Then
FSO.CreateFolder strTempFolder
End If
i = 1
Do Until FSO.FolderExists(strTempFolder) Or i > 6
Sleep i * 250
Application.StatusBar = "Waiting for SQL cache folder" & String(i Mod 4, ".")
Loop
If Not FSO.FolderExists(strTempFolder) Then
GoTo Retry
End If
If Right(strTempFolder, 1) <> "\" Then
strTempFolder = strTempFolder & "\"
End If
TempSQLFolder = strTempFolder
Application.StatusBar = False
End Function
Public Property Get FSO() As Scripting.FileSystemObject '
' Return a File System Object
On Error Resume Next
If m_objFSO Is Nothing Then
Set m_objFSO = CreateObject("Scripting.FileSystemObject") ' New Scripting.FileSystemObject
End If
If m_objFSO Is Nothing Then
Shell "Regsvr32.exe /s scrrun.dll", vbHide
Set m_objFSO = CreateObject("Scripting.FileSystemObject")
End If
Set FSO = m_objFSO
End Property
Public Sub SaveTable(Optional TableName As String = "*")
' Export a Table object to the local SQL Folder as a csv file
' If no name is specified, all tables are exported asynchronously
' This step is essential for running SQL on the tables
Dim wks As Excel.Worksheet
Dim oList As Excel.ListObject
Dim sFile As String
Dim bAsync As Boolean
If TableName = "*" Then
bAsync = True
Else
bAsync = False
End If
For Each wks In ThisWorkbook.Worksheets
For Each oList In wks.ListObjects
If oList.Name Like TableName Then
sFile = oList.Name
ArrayToCSV oList.Range.Value2, sFile, , , , , , , , bAsync
'Debug.Print "[" & sFile & ".csv] "
End If
Next oList
Next wks
SetSchema
End Sub
Public Sub RemoveTable(Optional TableName As String = "*")
On Error Resume Next
' Clear up the temporary 'Table' files in the user local temp folder:
Dim wks As Excel.Worksheet
Dim oList As Excel.ListObject
Dim sFile As String
Dim sFolder As String
sFolder = TempSQLFolder
For Each wks In ThisWorkbook.Worksheets
For Each oList In wks.ListObjects
If oList.Name Like TableName Then
sFile = oList.Name & ".csv"
If Len(Dir(sFile)) > 0 Then
Shell "CMD /c DEL " & Chr(34) & sFolder & sFile & Chr(34), vbHide ' asynchronous deletion
End If
End If
Next oList
Next wks
End Sub
Share and enjoy: this is all a horrible hack, but it gives you a stable SQL platform.
And we still don't have a stable 'native' platform for SQL on Excel: the Microsoft.ACE.OLEDB.14.0 Excel data provider still has the same memory leak as Microsoft.Jet.OLEDB.4.0 and the Excel ODBC driver that preceded it, twenty years ago.
Some notes:
sFullName = ActiveWorkbook.FullName
sSheet = ActiveSheet.Name
Set cn = CreateObject("adodb.connection")
scn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _
& sFullName _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
cn.Open scn
Set rs = CreateObject("adodb.recordset")
For Each c In Sheet4.UsedRange
sSQL = sSQL & c.Value & " "
Next
rs.Open sSQL, cn
Sheet5.Range("a10").CopyFromRecordset rs
There is an ODBC driver for Excel.
See: http://support.microsoft.com/kb/178717
And: http://msdn.microsoft.com/en-us/library/ms711711%28v=vs.85%29.aspx
In order to get data out of a database and into Excel you do the following steps.
Record a macro
Import external data, choose a new source, select DSN ODBC as the type of source.
Now choose Excel-file as the type of ODBC source.
Pick the Excel sheet you want to query.
Every table needs to be in a named range, leave the option select a table checked, Excel will not allow us to insert a query just yet.
Follow the wizard and save the .odc file. Open it again and choose edit query. Now you can insert your select statement.
Stop recording and edit the recorded macro to suit your needs.
It looks like source and target are odbc queries. You need to parse the table name out of those queries and replace SoureTable and TargetTable in your query with the right table names.
Sub ExecuteSQL()
Dim sSql As String
Dim rCell As Range
Dim adConn As ADODB.Connection
Dim adRs As ADODB.Recordset
Dim lWherePos As Long
Const sSOURCE As String = "SourceTable"
Const sTARGET As String = "TargetTable"
Const sODBC As String = "ODBC;"
'Buld the sql statement
For Each rCell In Intersect(wshSql.UsedRange, wshSql.Columns(1)).Cells
If Not IsEmpty(rCell.Value) Then
sSql = sSql & rCell.Value & Space(1)
End If
Next rCell
'replace the table names
sSql = Replace(sSql, sSOURCE, GetTableName(wshSource.QueryTables(1).CommandText), 1, 1)
sSql = Replace(sSql, sTARGET, GetTableName(wshTarget.QueryTables(1).CommandText), 1, 1)
'execute the query
Set adConn = New ADODB.Connection
adConn.Open Replace(wshSource.QueryTables(1).Connection, sODBC, "")
Set adRs = adConn.Execute(sSql)
'copy the results
wshResults.Range("A1").CopyFromRecordset adRs
adRs.Close
adConn.Close
Set adRs = Nothing
Set adConn = Nothing
End Sub
Function GetTableName(sSql As String) As String
Dim lFromStart As Long
Dim lFromEnd As Long
Dim sReturn As String
Const sFROM As String = "FROM "
Const sWHERE As String = "WHERE "
'find where FROM starts and ends
'I'm looking for WHERE as the end, but you'll need to look for everything possible, like ORDER BY etc.
lFromStart = InStr(1, sSql, sFROM)
lFromEnd = InStr(lFromStart, sSql, sWHERE)
If lFromEnd = 0 Then
sReturn = Mid$(sSql, lFromStart + Len(sFROM), Len(sSql))
Else
sReturn = Mid$(sSql, lFromStart + Len(sFROM), lFromEnd - lFromStart - Len(sFROM) - 1)
End If
GetTableName = sReturn
End Function
Another problem that you might run into is the way Excel (or MSQuery) constructs the SQL statements in an external data query. If you leave it as the default, you'll likely get something like this
SELECT * FROM `C:\somepath\myfile.mdb`.tblTable1 tblTable1 WHERE ...
I have no idea why it does it that way, but you can change it to
SELECT * FROM tblTable1 WHERE ...
and the above code should work. Parsing SQL statements sucks, so don't expect this to be easy. Once you think you have all the possibilities, another will pop up.
Finally, you should get the error "Too few parameters, expected 1" or something similar. In SourceTable, the first field is emp_no, but you have emp_id in your SQL. Make sure your SQL in the SQL sheet is correct. It can be frustrating trying to track down those errors.
I'm using very simple code which helps me to query worksheet range :
Sub hello_jet()
Dim rs As ADODB.Recordset
Dim cn As ADODB.Connection
Dim strQuery As String
Set cn = New ADODB.Connection
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=C:\yourPath\ADO_test.xls " & _
";Extended Properties=""Excel 8.0;HDR=Yes;"""
.Open
End With
'Microsoft.ACE.OLEDB.12.0 for database engine built in Windows 7 64
strQuery = "SELECT a,sum(c) FROM [Sheet1$A1:C6] GROUP BY a;"
''if range [Sheet1$A1:C6] is named as namedRange you can you its name directly in query:
'strQuery = "SELECT a,sum(c) FROM namedRange GROUP BY a;"
Set rs = cn.Execute(strQuery)
ActiveCell.CopyFromRecordset rs 'useful method
rs.Close
End Sub