Hi friends i am working on export excel rows to Sql Server 2008 Table
in that way i am checking the row already exist in table or not
my table has
sap_code
depot
size
entry_date
if table exist that record skip that row and check next row of excel with table
here goes my working code
' ===== Export Using ADO =====
Function ExportRangeToSQL(ByVal sourceRange As Range, _
ByVal conString As String, ByVal table As String) As Integer
On Error Resume Next
' Object type and CreateObject function are used instead of ADODB.Connection,
' ADODB.Command for late binding without reference to
' Microsoft ActiveX Data Objects 2.x Library
' ADO API Reference
' http://msdn.microsoft.com/en-us/library/ms678086(v=VS.85).aspx
' Dim con As ADODB.Connection
Dim con As Object
Set con = CreateObject("ADODB.Connection")
con.ConnectionString = conString
con.Open
' Dim cmd As ADODB.Command
Dim cmd As Object
Set cmd = CreateObject("ADODB.Command")
cmd.CommandType = 1 ' adCmdText
' Dim rst As ADODB.Recordset
Dim rst As Object
Set rst = CreateObject("ADODB.Recordset")
With rst
Set .ActiveConnection = con
.Source = "SELECT * FROM " & table
.CursorLocation = 3 ' adUseClient
.LockType = 4 ' adLockBatchOptimistic
.CursorType = 1 ' adOpenKeyset
.CursorType = 0 ' adOpenForwardOnly
.Open
' Do While Not .EOF
' .MoveNext
' Loop
' Column Mappings
Dim tableFields(100) As Integer
Dim rangeFields(100) As Integer
Dim exportFieldsCount As Integer
exportFieldsCount = 0
Dim col As Integer
Dim index As Integer
For col = 1 To .Fields.Count - 1
index = Application.Match(.Fields(col).Name, sourceRange.Rows(1), 0)
If index > 0 Then
exportFieldsCount = exportFieldsCount + 1
tableFields(exportFieldsCount) = col
rangeFields(exportFieldsCount) = index
End If
Next
If exportFieldsCount = 0 Then
ExportRangeToSQL = 1
Exit Function
End If
' Fast read of Excel range values to an array
' for further fast work with the array
Dim arr As Variant
arr = sourceRange.Value
' Column names should be equal
' For col = 1 To exportFieldsCount
' Debug.Print .Fields(tableFields(col)).Name & " = " & arr(1, rangeFields(col))
' Next
' The range data transfer to the Recordset
Dim row As Long
Dim rowCount As Long
rowCount = UBound(arr, 1)
Dim val As Variant
For row = 2 To rowCount
' Testing the Ledger data to insert
Dim qu As String
Dim br, de, si, da As String
br = arr(row, rangeFields(1)) ' sap_code from excel
de = arr(row, rangeFields(2)) ' depot from excel
si = arr(row, rangeFields(3)) ' size from excel
da = arr(row, rangeFields(5)) ' entry_date from excel
Set con = CreateObject("ADODB.Connection")
con.ConnectionString = conString
con.Open
Dim rstTest As ADODB.Recordset
Set rstTest = New ADODB.Recordset
With rstTest
.CursorLocation = adUseClient
.Open "select TOP 1 sap_code, depot, size, entry_date from openstock where " + "sap_code='" + br + "' and depot='" + de + "' and size='" + si + "' and entry_date='" + da + "' ORDER BY id DESC", con, adOpenStatic, adLockBatchOptimistic, adCmdText
MsgBox "SAP_CODE" & br & "Depot" & de & "Size" & si & "entry_date" & da & "Duplicate Entry Not Entered into Database"
If br = rstTest.Fields("sap_code").Value And _
de = rstTest.Fields("depot").Value And _
si = rstTest.Fields("size").Value And _
da = rstTest.Fields("entry_date").Value Then
Else
End With **NOte: Error showing here as End With with out With**
.AddNew
For col = 1 To exportFieldsCount
val = arr(row, rangeFields(col))
If IsEmpty(val) Then
Else
.Fields(tableFields(col)) = val
End If
Next
End If
Next **NOte: Problem showing here as Next with out FOR**
.UpdateBatch
End With
rst.Close
Set rst = Nothing
con.Close
Set con = Nothing
ExportRangeToSQL = 0
End Function
Suggestion: Always indent your code. So even if you look at the code say 6 months down the line, you will know what the code does. Indentation also helps you catch errors which occur as it happened in the code above
Here is an example
Sub Sample()
For i = 1 to 5
For j = 1 to 10
For k = 1 to 7
If a = 10 then
End If
Next
Next
Next
End Sub
The same code can be written as
Sub Sample()
For i = 1 to 5
For j = 1 to 10
For k = 1 to 7
If a = 10 then
End If
Next
Next
Next
End Sub
Another suggestion (it is not mandatory though) For a better understanding where does a For loop ends, it is advisable to write Next as say Next i.
So the above code can be further improved to
Sub Sample()
For i = 1 to 5
For j = 1 to 10
For k = 1 to 7
If a = 10 then
End If
Next k
Next j
Next i
End Sub
If you implement the above suggestion, you will notice that this section of your code
With rstTest
.CursorLocation = adUseClient
.Open "select TOP 1 sap_code, depot, size, entry_date from openstock where " + "sap_code='" + br + "' and depot='" + de + "' and size='" + si + "' and entry_date='" + da + "' ORDER BY id DESC", con, adOpenStatic, adLockBatchOptimistic, adCmdText
MsgBox "SAP_CODE" & br & "Depot" & de & "Size" & si & "entry_date" & da & "Duplicate Entry Not Entered into Database"
If br = rstTest.Fields("sap_code").Value And _
de = rstTest.Fields("depot").Value And _
si = rstTest.Fields("size").Value And _
da = rstTest.Fields("entry_date").Value Then
Else
End With **NOte: Error showing here as End With with out With**
.AddNew
For col = 1 To exportFieldsCount
val = arr(row, rangeFields(col))
If IsEmpty(val) Then
Else
.Fields(tableFields(col)) = val
End If
Next
End If
Next **NOte: Problem showing here as Next with out FOR**
Solution: Above code can be re-written as
For row = 2 To rowCount
'
'
'
With rstTest
.CursorLocation = adUseClient
.Open "select TOP 1 sap_code, depot, size, entry_date from openstock where " + _
"sap_code='" + br + "' and depot='" + de + "' and size='" + si + _
"' and entry_date='" + da + "' ORDER BY id DESC", con, adOpenStatic, _
adLockBatchOptimistic, adCmdText
MsgBox "SAP_CODE" & br & "Depot" & de & "Size" & si & "entry_date" & da & _
"Duplicate Entry Not Entered into Database"
If br = rstTest.Fields("sap_code").Value And _
de = rstTest.Fields("depot").Value And _
si = rstTest.Fields("size").Value And _
da = rstTest.Fields("entry_date").Value Then
Else
'~~> Removed End With from here
'End With **NOte: Error showing here as End With with out With**
.AddNew
For col = 1 To exportFieldsCount
val = arr(row, rangeFields(col))
If IsEmpty(val) Then
Else
.Fields(tableFields(col)) = val
End If
Next col
End If
End With '<~~ Pasted it here
Next row
Related
I have a excel workbook that pulls data into a table users can then fill in the missing dates in column 11. Column 1 is the unique identifier that matches the ID column in the SQL table. I want to create a macro that runs when the workbook is closed and will update the SQL table with the filled in dates, but I am struggling with the code. I have have tried two different things but neither seem to work.
Option 1:
Private Sub tableupdate()
Dim con As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim rst As New ADODB.Recordset
Dim i As Long
Dim vDB As Variant
Dim ws As Worksheet
con.connectionstring = "Provider=SQLOLEDB;Password=*********;User ID=clx_write; Initial Catalog=DPEDataMartDBPrd01; Data Source=tcp:dscusnoramcloroxprd01.database.windows.net,1433;"
con.Open
Set cmd.ActiveConnection = con
Set ws = ActiveSheet
vDB = ws.Range("A4").CurrentRegion
For i = 2 To UBound(vDB, 1)
cmd.CommandText = "UPDATE [dbo].[all_load_control] set Driver_arr_dte = ' " & vDB(i, 2) & " ' WHERE mst_ship_num = ' " & vDB(i, 1) & " ' "
cmd.Execute
Next i
con.Close
Set con = Nothing
End Sub
option 2:
Private Sub uplodblanks()
Dim r, c, con, dstring
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim lRow
Dim ssql As String
con = "Provider=SQLOLEDB;Password=********;User ID=clx_write; Initial Catalog=DPEDataMartDBPrd01; Data Source=tcp:dscusnoramcloroxprd01.database.windows.net,1433;"
r = 1
c = 1
Worksheets("WTUpload").Calculate
lRow = Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
cn.Open con
i = 1
For i = 1 To lRow
ssql = "update dbo.cxu_all_load_control set driver_arr_dte = " & CDate(Sheets("WTUpload").Cells(i, 11)) & " where mst_ship_num = " & CDbl(Sheets("WTUpload").Cells(i, 11)) & " ; "
cn.Execute ssql
Next i
cn.Close
End Sub
Any help as to why neither of these are working would be great
Replace the mydbConnect() function with you own method of getting a connection.
Sub tableupdate2()
Const COL_NUM As String = "A"
Const COL_DATE As String = "K"
Const TABLE As String = "dbo.all_load_control"
' define update sql
Const SQL As String = " UPDATE " & TABLE & _
" SET Driver_arr_dte = CAST(? AS DATETIME2) " & _
" WHERE mst_ship_num = ? "
' establish connection and create command object
Dim con As Object, cmd As Object, sSQL As String
Set con = mydbConnect() ' establish connection
Set cmd = CreateObject("ADODB.Command")
With cmd
.ActiveConnection = con
.CommandText = SQL
.CommandType = 1 'adCmdText
.Parameters.Append .CreateParameter("P1", adVarChar, 1, 20) '
.Parameters.Append .CreateParameter("P2", adVarChar, 1, 50) ' adParamInput = 1
End With
' prepare to get data from spreadsheet
Dim wb As Workbook, ws As Worksheet, iLast As Integer, iRow As Integer
Set wb = ThisWorkbook
Set ws = wb.Sheets("WTUpload")
iLast = ws.Range(COL_NUM & Rows.count).End(xlUp).Row
Dim p1 As String, p2 As String, count As Long
' scan sheet and update db
Debug.Print "Updates " & Now
With cmd
For iRow = 1 To iLast
p1 = Format(ws.Range(COL_DATE & iRow).Value, "yyyy-mm-dd hh:mm")
p2 = ws.Range(COL_NUM & iRow).Value
If len(p2) > 0 Then
.Parameters(0).Value = p1
.Parameters(1).Value = p2
Debug.Print "Row ", iRow, "p1=" & p1, "P2=" & p2
.Execute
count = count + 1
End If
Next
End With
' end
MsgBox "Rows processed = " & count, vbInformation, "Updates Complete"
con.Close
Set con = Nothing
End Sub
Edit - added connection and test code
Function mydbConnect() As Object
Dim sConStr As String
sConStr = "Provider=SQLOLEDB;Password=*********;User ID=clx_write;" & _
"Initial Catalog=DPEDataMartDBPrd01;" & _
"Data Source=tcp:dscusnoramcloroxprd01.database.windows.net,1433;"
Set mydbConnect = CreateObject("ADODB.Connection")
mydbConnect.Open sConStr
End Function
Sub test()
Dim con As Object, rs As Object
Set con = mydbConnect()
Set rs = con.Execute("SELECT CURRENT_TIMESTAMP")
MsgBox rs.Fields(0), vbInformation, "Current Date/Time"
End Sub
I get data from SQL Server and now I want to copy it in Excel worksheet.
I tried to format "start_date" but it applied the format only on the first column, all others display as stored in SQL Server.
Sub ReadMBDataFromSQL()
Dim Server_Name, Database_Name, User_ID, Password, SQLStr As String
Set Cn = CreateObject("ADODB.Connection")
Set RS = New ADODB.Recordset
Server_Name = ""
Database_Name = ""
User_ID = ""
Password = ""
SQLStr = "SELECT lot, po, start_date, input_sponge_type, input_sponge_type FROM PalladiumNitrateMB WHERE start_date >= '" & Format(Range("start"), "mm-dd-yyyy") & "' AND start_date < '" & Format(Range("end"), "mm-dd-yyyy") & "' ORDER BY lot ASC"
Set Cn = New ADODB.Connection
Cn.Open "Driver={SQL Server};Server=" & Server_Name & ";Database=" & Database_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";"
RS.Open SQLStr, Cn, adOpenKeyset, adLockBatchOptimistic
With Worksheets("PdNitrateMassBalance").Range("A5:N600")
RS("start_date") = Format(RS("start_date"), "dd/mm/yyyy")
.ClearContents
.CopyFromRecordset RS
End With
RS.Close
Set RS = Nothing
Cn.Close
Set Cn = Nothing
End Sub
Try replacing this part
With Worksheets("PdNitrateMassBalance").Range("A5:N600")
RS("start_date") = Format(RS("start_date"), "dd/mm/yyyy")
.ClearContents
.CopyFromRecordset RS
End With
With this
With Worksheets("PdNitrateMassBalance")
With .Range("A5:N600")
.ClearContents
.CopyFromRecordset RS
End With
FixDatesFromYYYY_MM_DD .Range("A:A"), "dd/mm/yyyy"
End With
And additional sub:
Sub FixDatesFromYYYY_MM_DD(DatesRange As Range, Format As String)
Dim r As Range
Dim firstDash As Integer, secondDash As Integer, i As Integer
For Each r In DatesRange
If Not r.Value = "" Then
firstDash = 0
secondDash = 0
For i = 1 To Len(r.Text)
If Mid(r.Text, i, 1) = "-" Then
If Not firstDash = 0 Then
secondDash = i
Exit For
Else
firstDash = i
End If
End If
Next
With r
.Value = DateSerial(Left(r.Text, 4), Mid(r.Text, firstDash + 1, IIf(secondDash = 7, 1, 2)), Mid(r.Text, secondDash + 1))
.NumberFormat = Format
End With
End If
Next
End Sub
Update
Added a sub to convert dates from "yyyy-mm-dd" text format.
Problem solved by modifying of the SQL query, i request the date with
convert(varchar,start_date,103)
So I have this list that is X rows long.
Each has 5 columns: Equipment, Type, Material, Size and Price this is in the Sheet2.
I also have a database in sheet1 with the same column filled in. I have written a code in VBA that for each row in Sheet2 I can fill in Equipment, Type, Material and Size and it will search in the database in sheet1 the matching price for those criteria and past this under the column Price in Sheet2.
Now the problem that I have is if I for example filled in row 1, row 2 and row 3 after each other it works and gives me the price but if I later want to change the variables in row 1 or 2 it doesn't change/update the Price but it still works for row 3 and forward.
How do I make it so that it does change/Update the price in row 1 and 2 if I change the variables there.
my code:
Option Explicit
Public r As Long
Public Const adOpenStatic = 3
Public Const adOpenKeySet = 1
Public Const adLockReadOnly = 1
Sub cmdSearch_Click()
Dim strCriteriaEquipment As String
Dim strCriteriaType As String
Dim strCriteriaMaterial As String
Dim strCriteriaSize As String
Dim strSQL As String
Dim strSourceTable As String
Dim c As Long, LR As Long
LR = Cells(Rows.Count, 2).End(xlUp).Row
For r = 1 To LR
c = 2
With Worksheets("Summary")
strCriteriaEquipment = Worksheets("Summary").Cells(r, c).Value
strCriteriaType = Worksheets("Summary").Cells(r, c + 1).Value
strCriteriaMaterial = Worksheets("Summary").Cells(r, c + 2).Value
strCriteriaSize = Worksheets("Summary").Cells(r, c + 3).Value
End With
Next r
strSourceTable = "[DB$" & Replace(Worksheets("DB").Range("SourceData").Address, "$", "") & "]"
strSQL = "SELECT [Price] FROM " & strSourceTable & vbNewLine
strSQL = strSQL & "WHERE [Equipment]= """ & strCriteriaEquipment & """" & vbNewLine
strSQL = strSQL & "AND [Type]=""" & strCriteriaType & """" & vbNewLine
strSQL = strSQL & "AND [Material]=""" & strCriteriaMaterial & """" & vbNewLine
strSQL = strSQL & "AND [Size]=""" & strCriteriaSize & """;"
Dim rstRecordSet As Object 'ADODB.Recordset
Dim con As Object 'ADODB.Connection
Dim strWorkBookPath As String
strWorkBookPath = ThisWorkbook.FullName
Set con = CreateObject("ADODB.Connection")
Set rstRecordSet = CreateObject("ADODB.RecordSet")
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strWorkBookPath & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
rstRecordSet.Open strSQL, con, adOpenStatic, adLockReadOnly
With Worksheets("Summary")
For r = r - 29 To LR
c = 5
If Not (rstRecordSet.EOF And rstRecordSet.BOF) Then
.Range("ResultTable").Cells(r, c).CopyFromRecordset rstRecordSet
Else
.Range("ResultTable").Cells(r, c).Value = "Data Not Found!"
End If
Next r
End With
rstRecordSet.Close
con.Close
Set rstRecordSet = Nothing
Set con = Nothing
strWorkBookPath = vbNullString
strSQL = vbNullString
strCriteriaEquipment = vbNullString
strCriteriaType = vbNullString
strCriteriaMaterial = vbNullString
strCriteriaSize = vbNullString
strSourceTable = vbNullString
End Sub
Public Function UniqueStringWithDelimiter(varArray As Variant, strDelimiter As String) As Variant
Dim varTemp() As Variant
Dim lngLoop As Long
Dim strConcat As String
ReDim Preserve varTemp(0 To 0)
varTemp(0) = varArray(0, 0)
strConcat = strConcat & varArray(0, 0)
For lngLoop = 1 To UBound(varArray, 2)
If InStr(1, strConcat, varArray(0, lngLoop), vbTextCompare) = 0 Then
strConcat = strConcat & strDelimiter & varArray(0, lngLoop)
End If
Next lngLoop
UniqueStringWithDelimiter = strConcat.
strConcat = vbNullString
Erase varTemp
End Function
Now to update everytime I change something in Sheet2 I just wrote this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call cmdSearch_Click
End Sub
So again my question how do I update/change the price if I change a variable in row 1 or row 2 if row 3 was the last row that was used in the sheet.
This is the datbase that I am using:
This is Sheet2:
1) One immediate problem I see that will cause your issue (and there may be more, but I don't have time to dissect so much at this moment), is that the initial loop:
For r = 1 To LR
c = 2
With Worksheets("Summary")
strCriteriaEquipment = Worksheets("Summary").Cells(r, c).Value
strCriteriaType = Worksheets("Summary").Cells(r, c + 1).Value
strCriteriaMaterial = Worksheets("Summary").Cells(r, c + 2).Value
strCriteriaSize = Worksheets("Summary").Cells(r, c + 3).Value
End With
Next r
is not doing what you may expect. At the end of this loop you only have set the values for the last row of data (I suspect row 3) to pass into your query.
You'll need to write your queries inside this loop as well so that the query is run for each set of criteria in each line.
For example:
For r = 1 to LR
c = 2
With Worksheets("Summary")
'code to set criteria
End With
'code to download data price
'code to stick data and price in summary tab
Next r
2) Also, make sure to qualify all your objects. The line
LR = Cells(Rows.Count, 2).End(xlUp).Row
may return different results if the sheet you desire to be active is not actually active. Better to say this, for example, and leave out guess works:
LR = Worksheets("Summary").Cells(Rows.Count, 2).End(xlUp).Row
3) Using Worksheet_SelectionChange will fire your code every time you move from one to another in your worksheet. If you want to only fire the code when you make a change to the criteria in your data, use Worksheet_Change instead. You can also define which specific cells being changes will run the code as well.
New to vb and am struggling with returning data from my recordset if variable equals a value in my array.
I think what I've done so far is correct but having trouble with the final bit. I need to script something to say "if value from range equals a value in my array then print the recordset".
I hope someone can help. I'm also new to vb so any suggestions on how to improve my code would be great. Thanks in advance!! Brian
Sub FindCardOrdersv2()
' Initialize variables.
Dim cn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim provStr As String
Dim intMaxCol As Integer
Dim intMaxRow As Integer
Dim rsFilter As Range
Dim i As Integer
Dim rng As Variant
Dim payid(1 To 10) As String
Dim tw As ThisWorkbook
Workbooks("cleanse.xlsm").Activate
Worksheets("Sheet1").Activate
' Create new instances
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
' sql query
sql = "SELECT TOP 100 t.tri_transactionidcode," _
& "SUBSTRING(t.tri_reference, 1, 9) AS merchantref," _
& "t.tri_additionalreferencenumber, t.CreatedOn, t.tri_amount, ISNULL(t.tri_paymenttransactiontypeidName, 'Online')" _
& " FROM dbo.tri_onlinepayment t INNER JOIN dbo.tri_transaction tr ON tr.tri_onlinepaymentid = t.tri_onlinepaymentId" _
& " WHERE t.tri_transactionresult = 9"
' Specify the OLE DB provider.
cn.Provider = "sqloledb"
' Specify connection string on Open method.
cn.Open "Data Source=IFL-SQL11;Database=IFL_MSCRM;Trusted_Connection=yes;Integrated Security=SSPI"
' Assign active connection to recordset
Set rs.ActiveConnection = cn
'intMaxCol = rs.Fields.Count
' Define cursors and open sql
With rs
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Open sql
End With
For i = 1 To 3
payid(i) = rs.Fields.Item(0)
Debug.Print rs(0)
Debug.Print rs(1)
Debug.Print rs(3)
rs.MoveNext
Next i
'rsFilter = Range("A1:A10")
For Each rsFilter In Range("A1:A10").Cells
If rsFilter.Value = payid Then
Debug.Print rs(1)
rs.MoveNext
End If
Next
'If rs.RecordCount > 0 Then
' With Worksheets("Sheet1")
' .Range("B1:B2").CopyFromRecordset rs
' End With
'End If
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
End Sub
Add an extra for loop inside to compare every value in the range to the array values
For Each rsFilter In Range("A1:A10").Cells
For i=1 To 3
If rsFilter.Value = payid(i) Then
Debug.Print rs(1)
rs.MoveNext
End If
Next i
Next
I Have a Database in MS ACCESS in which i have a ECount field which holds some Counts
is there any way i can pull that call in VBA code where i am generating a new mail which should pull the count in the mail.
Private Sub Command_Click()
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem
Dim ThisDay As Date
ThisDay = Format(Now, "mm/dd/yy")
Set objOutlook = CreateObject("Outlook.application")
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.To = ""
.CC = ""
.Subject = "Daily Email Processed " *(Thisday)
.Body = "Hi," + vbNewLine + vbNewLine + vbNewLine + "Please find below the number of Emails processed for the " + vbNewLine + vbNewLine + "Email Count = " (**ECOUNT**) + vbNewLine + "O Count = " (**OCount**)
.Attachments.Add ""
.Attachments.Add ""
.Display
'.ReadReceiptRequested
End With
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim sCount As String
Set db = CurrentDb()
Set rs1 = db.OpenRecordset("SELECT TOP 1 ECounter FROM [Email Query]")
If rs1.RecordCount > 0 Then
rs1.MoveFirst
sCount = rs1.Fields("ECount")
End If
rs1.Close
set rs1 = Nothing
set db = Nothing
sCount will hold the value
The easiest way to retrieve a singular field from a table/query is to use the DLOOKUP function of Access.
So you could write:
.Body = "Hi," + vbNewLine + vbNewLine + vbNewLine + _
"Please find below the number of Emails processed for the " + vbNewLine + vbNewLine + _
"Email Count = " + DLookup("ECount", "SourceTableOrQuery", "Criteria1 = 5 and Criteria2 = ""Test""") + vbNewLine + _
"O Count = " + DLookup("OCount", "SourceTableOrQuery")
Alternatively, if you don't have the count yet, but want to count the number of items, you can use the 'DCount` function.
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim sCount As String
Set db = CurrentDb()
Set rs1 = db.OpenRecordset("SELECT TOP 1 ECounter FROM [Email Query]")
If rs1.RecordCount > 0 Then
rs1.MoveFirst
sCount = rs1.Fields("ECount")
End If
rs1.Close
set rs1 = Nothing
set db = Nothing