VBA Email Generator - Send Notice to Employee with Overdue Tickets
Trying to generate emails to notify user that their ticket is overdue. The program runs and generates the email, however if a employee has multiple tickets overdue, it sends them multiple emails as opposed to one with all overdue items.
Your help is really appreciated!!!!
Option Compare Database
Option Explicit
Public Sub SendSerialEmail()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rec As DAO.Recordset
Dim emailTo As String
Dim nameemployee As String
Dim emailSubject As String
Dim emailText As String
Dim strQry As String
Dim aHead(1 To 6) As String
Dim aRow(1 To 6) As String
Dim aBody() As String
Dim lCnt As Long
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outStarted As Boolean
'Create the header row
aHead(1) = "Ticket#"
aHead(2) = "Summary"
aHead(3) = "Ticket Status"
aHead(4) = "Date Created"
aHead(5) = "# Business Days Open"
aHead(6) = "Assigned To"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outStarted = True
End If
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
Do Until rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("ID")
aRow(2) = rec("title")
aRow(3) = rec("name")
aRow(4) = rec("created")
aRow(5) = rec("workdaysopen")
aRow(6) = rec("full_name")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
If outStarted Then
outApp.Quit
End If
Do Until rs.EOF
emailTo = rs.Fields("email").Value
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.CC = "myemail#gmail.com"
outMail.Subject = emailSubject
outMail.HTMLBody = "<BODY style=font-size:11pt;font-family:Segoe UI>" & "Hi " & nameemployee & "," & _
"<br>" & "<br>" & _
"<BODY style=font-size:14pt;font-family:Segoe UI>" & "<b><span style=""color:#B22222"">Overdue Termination Tickets</b>" & _
Join(aBody, vbNewLine) & _
"<br>" & _
"<BODY style=font-size:11pt;font-family:Segoe UI>" & "<b><i><span style=""color:#000000"">**Please note that tickets are overdue.</i></b>"
outMail.Display
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outStarted Then
outApp.Quit
End If
Set outMail = Nothing
Set outApp = Nothing
End Sub
I'll invite your to test the following code, I've made a test of this code.
The idea is to check if an email address has already been used, in order to send a single email per user.
Send all tickets to all users with 1-single email per user
Public Function IsEmailInArray(strEmail As String, arr() As String, lUbound As Long) As Boolean
Dim i
For i = 1 To lUbound
If arr(i) = strEmail Then
IsEmailInArray = True
Exit Function
End If
Next
IsEmailInArray = False
End Function
Public Sub so66016960SendSerialEmail()
Dim db As DAO.Database
Dim rs As DAO.Recordset
'Dim rec As DAO.Recordset
Dim emailTo As String
Dim nameemployee As String
Dim emailSubject As String
Dim emailText As String
Dim strQry As String
Dim aHead(1 To 6) As String
Dim aRow(1 To 6) As String
Dim aBody() As String
Dim lCnt As Long
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outStarted As Boolean
Dim strTable As String
'Create the header row
aHead(1) = "Ticket#"
aHead(2) = "Summary"
aHead(3) = "Ticket Status"
aHead(4) = "Date Created"
aHead(5) = "# Business Days Open"
aHead(6) = "Assigned To"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outStarted = True
End If
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
' Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
'
' get listing table of all overdue tickets:
'
Do Until rs.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rs("ID")
aRow(2) = rs("title")
aRow(3) = rs("name")
aRow(4) = rs("created")
aRow(5) = rs("workdaysopen")
aRow(6) = rs("full_name")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rs.MoveNext
Loop
aBody(lCnt) = aBody(lCnt) & "</table>"
'
strTable = Join(aBody, vbNewLine)
'
'If outStarted Then
' outApp.Quit
'End If
'
'
' rewind:
'
rs.MoveFirst
'
' now we reuse aBody() array as temporay array to used email addresses:
'
lCnt = 0
'
Do Until rs.EOF
emailTo = rs.Fields("email").Value
'
' if email is not yet used:
'
If (Not IsEmailInArray(emailTo, aBody, lCnt)) Then
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.CC = "myemail#gmail.com"
outMail.Subject = emailSubject
outMail.HTMLBody = "<html><body style=font-size:11pt;font-family:Segoe UI>" & _
"Hi " & nameemployee & "," & _
"<br>" & "<br>" & _
"<b><span style=""font-size:14pt;font-family:Segoe UI;color:#B22222"">Overdue Termination Tickets</b>" & _
strTable & _
"<br>" & _
"<b><i><span style=""font-size:11pt;font-family:Segoe UI;color:#000000"">**Please note that tickets are overdue.</i></b>" & _
"</body></html>"
outMail.Display
'
' memory the email address just sent:
'
lCnt = lCnt + 1
aBody(lCnt) = emailTo
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outStarted Then
outApp.Quit
End If
Set outMail = Nothing
Set outApp = Nothing
End Sub
To send email with only her/his own information, we ORDER BY email, like this:
Public Function send1Mail(ByVal outApp, ByVal strEmail2Use, ByVal nameemployee, ByVal emailSubject, ByVal emailText, ByVal strTable)
Dim outMail As Outlook.MailItem
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = strEmail2Use
outMail.CC = "myemail#gmail.com"
outMail.Subject = emailSubject
outMail.HTMLBody = "<html><body style=font-size:11pt;font-family:Segoe UI>" & _
"Hi " & nameemployee & "," & _
"<br>" & "<br>" & _
"<b><span style=""font-size:14pt;font-family:Segoe UI;color:#B22222"">Overdue Termination Tickets</b>" & _
strTable & _
"<br>" & _
"<b><i><span style=""font-size:11pt;font-family:Segoe UI;color:#000000"">**Please note that tickets are overdue.</i></b>" & _
"</body></html>"
outMail.Display
Set outMail = Nothing
send1Mail = 1
End Function
Public Sub SendSerialEmail2Each()
Dim db As DAO.Database
Dim rs As DAO.Recordset
'Dim rec As DAO.Recordset
Dim emailTo As String
Dim nameemployee As String
Dim emailSubject As String
Dim emailText As String
'Dim strQry As String
'Dim aHead(1 To 6) As String
'Dim aRow(1 To 6) As String
'Dim aBody() As String
Dim lCnt As Long
Dim outApp As Outlook.Application
'Dim outMail As Outlook.MailItem
Dim outStarted As Boolean
'
' nRows: number of rows in the table
' strTable: html table
' strTableHeader: html table header
' strEmail2Use: email address to send message
'
Dim nRows As Long
Dim strTable As String, strTableHeader As String, strEmail2Use As String
'Create the header row
' aHead(1) = "Ticket#"
' aHead(2) = "Summary"
' aHead(3) = "Ticket Status"
' aHead(4) = "Date Created"
' aHead(5) = "# Business Days Open"
' aHead(6) = "Assigned To"
' lCnt = 1
' ReDim aBody(1 To lCnt)
' strTableHeader = "<table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
'
strTableHeader = "<table border='2'>" & _
"<tr>" & _
"<th>Ticket#</th>" & _
"<th>Title</th>" & _
"<th>Name</th>" & _
"<th>Date Create</th>" & _
"<th># Business Days Open</th>" & _
"<th>Assigned To</th>" & _
"</tr>"
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outStarted = True
End If
Set db = CurrentDb
'
' ORDRER BY email is important here:
'
Set rs = db.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets ORDER BY email;")
' Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
nRows = rs.RecordCount
'
' initialize:
'
lCnt = 0
strEmail2Use = ""
strTable = ""
'
Do Until rs.EOF
lCnt = lCnt + 1
'
' get email of the current record:
'
emailTo = rs.Fields("email").Value
'
' if first record: save email address and name.
'
If (lCnt = 1) Then
strEmail2Use = emailTo
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
'
' send the email if address changes:
'
ElseIf (strEmail2Use <> emailTo) Then
'
' close the html table:
'
strTable = strTableHeader & strTable & "</table>"
'
' send 1 single mail:
'
send1Mail outApp, strEmail2Use, nameemployee, emailSubject, emailText, strTable
strEmail2Use = emailTo
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
strTable = ""
End If
'
' aggregate all records per user for tr's:
'
strTable = strTable & _
"<tr>" & _
"<td>" & rs("ID") & "</td>" & _
"<td>" & rs("title") & "</td>" & _
"<td>" & rs("name") & "</td>" & _
"<td>" & rs("created") & "</td>" & _
"<td>" & rs("workdaysopen") & "</td>" & _
"<td>" & rs("full_name") & "</td>" & _
"</tr>"
'
' also send email at the last row of recordset:
'
If (lCnt = nRows) Then
'
' close the html table:
'
strTable = strTableHeader & strTable & "</table>"
'
' send 1 single mail:
'
send1Mail outApp, strEmail2Use, nameemployee, emailSubject, emailText, strTable
'
End If
'
' move next:
'
rs.MoveNext
Loop
'
' do this to save RAM:
'
rs.Close
Set rs = Nothing
Set db = Nothing
If outStarted Then
outApp.Quit
End If
Set outApp = Nothing
End Sub
Tested data Screenshot:
Generating the following Outlook email Windows to click and send.
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