#Niton solved my first question for me, which was how to pull in data from an Excel file in a way that would loop through until a new email address was found. It allows me to take data from multiple lines (and a couple fields on those lines) and place it into an Outlook email.
My problem now is that when it does so, I need it to be included in the body of an email. So there would be some text such as a greeting, then 'you have these vouchers that we need paid off, please...EXCEL DATA HERE...Thank you for looking at this, here is the address you can send to, and if you need to update us, email us back'. That wording is not complete and will be changed, but that is the general idea...getting the Excel text into the body of the email. I have added some fields that are pulled to the strVoucher as shown in the code.
I have tried different iterations as at first the Excel info would just repeat along with the text over and over. I then was able to separate at least part of the email code so that it would put in the first greeting piece of text, but then I am stuck in trying to get it to add more text after the Excel data without repeating all the text over and over. I tried to add another 'With Outmail' section after the strVoucher piece is added, but that just overrode the whole email.
Here is my code as it stands now. Thanks #niton!
Option Explicit
Sub oneEmail_SortedEmailAddresses()
Dim OutApp As Object
Dim OutMail As Object
Dim strVoucher As String
Dim lr As Long
Set OutApp = CreateObject("Outlook.Application")
lr = ActiveSheet.UsedRange.Rows.Count
Dim toAddress As String
Dim i As Long
Dim refundDescYes As Boolean
Dim sigString As String
Dim strbody As String
Dim strname As String
Dim strname2 As String
Dim strCheckNbr As String
Dim strCheckDate As String
Dim strCheckAmt As String
Dim strCheckTst As String
Rows("1:6").Select
Selection.Delete
Range("A1:N1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("Check Reconciliation Status").AutoFilter.Sort. _
SortFields.Clear
ActiveWorkbook.Worksheets("Check Reconciliation Status").AutoFilter.Sort. _
SortFields.Add2 key:=Range("A1"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Check Reconciliation Status").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("2:5").Select
Selection.Delete Shift:=xlUp
Range("i2") = "Yes"
Range("I2").AutoFill Destination:=Range("I2:I" & lr)
For i = 2 To lr
Set OutApp = CreateObject("Outlook.Application")
'sigString = Environ("appdata") &
'"\Microsoft\Signatures\Uncashed Checks.htm"
' If Dir(sigString) <> "" Then
' signature = GetBoiler(sigString)
' Else
' signature = ""
' End If
' Select Case Time
' Case 0.25 To 0.5
' GreetTime = "Good morning"
' Case 0.5 To 0.71
' GreetTime = "Good afternoon"
' Case Else
' GreetTime = "Good evening"
' End Select
' Email address
If ActiveSheet.Range("N" & i).Value <> "" Then
' One email per email address
' This assumes the addresses are sorted
If ActiveSheet.Range("N" & i).Value <> toAddress Then
If Not OutMail Is Nothing Then
If refundDescYes = True Then
OutMail.display
Else
OutMail.Close 1 ' olDiscard
End If
End If
toAddress = ActiveSheet.Range("N" & i).Value
Debug.Print toAddress
Set OutMail = Nothing
refundDescYes = False
Set OutMail = OutApp.CreateItem(0)
With OutMail
strname = Cells(i, "A").Value
strname2 = strname
If InStr(Cells(i, "A"), ",") Then strname2 = Trim(Split(strname, ",")(1))
.To = toAddress
.Subject = "Open Vouchers"
strbody = "<Font face = TimesNewRoman p style=font-size:18.5px color = #0033CC)<br><br>You are receiving this email because our records show you have vouchers open as follows: " & _
"<br><br>Voucher #: " & strVoucher & _
"<br>Check Date: " & strCheckDate & _
"<br>Check Amount: " & strCheckAmt
.HTMLBody = "<Font face = TimesNewRoman p style=font-size:26.5px color = #0033CC><B><p style=font-size:18.5px>Dear " & strname2 & ", " & strbody & "<br>"
.HTMLBody = "<B><br><br>Please reply to this email with any questions." & _
"<br><br>***If we do not receive a reply from you within the next 30 days, you will not be paid."
End With
End If
' Refund Desc
If ActiveSheet.Range("I" & i).Value = "Yes" Then
refundDescYes = True
' Voucher
strCheckTst = "Check Number "
strCheckNbr = Cells(i, "K").Value
strVoucher = strCheckTst & Cells(i, "D").Value & " " & Cells(i, "K").Value
strCheckDate = Cells(i, "L").Value
strCheckAmt = Cells(i, "H").Value
With OutMail
.HTMLBody = .HTMLBody & "<br>" & strVoucher
End With
End If
End If
Next
If Not OutMail Is Nothing Then
If refundDescYes = True Then
OutMail.display
Else
OutMail.Close 1 ' olDiscard
End If
End If
Set OutMail = Nothing
Debug.Print "Done."
End Sub
This example below probably will not work because you didn't post a copy of your data on the worksheet, so I had to make some assumptions. Use this as an example of how to organize your code.
Your main issue is the organization of your code, both inside and outside your loop. In my example, I've simplified the main logic by pulling big blocks of code out into other routines. This should make the overall "flow" of your code easier to read and work with.
Notice a couple things:
Always fully qualify your references to ranges, worksheets, and workbooks.
Avoid magic numbers
Rework the code below into your own data and see if it helps.
EDIT: to send only one email per vendor
Option Explicit
Const NAME_COL As Long = 1
Const VOUCHER_COL As Long = 4
Const DATE_COL As Long = 12
Const CHKNUM_COL As Long = 11
Const AMT_COL As Long = 8
Const TOADDR_COL As Long = 14
Sub Example()
Dim statusWS As Worksheet
Set statusWS = ThisWorkbook.Sheets("Check Reconciliation Status")
' PrepareData statusWS
'--- only do this once
Dim outlookApp As Outlook.Application
Set outlookApp = AttachToOutlookApplication
Dim addresses As Dictionary
Set addresses = GetEmailAddresses(statusWS)
Dim emailAddr As Variant
For Each emailAddr In addresses
'--- create the email now that everything is ready
Dim email As Outlook.MailItem
Set email = outlookApp.CreateItem(olMailItem)
With email
.To = emailAddr
.Subject = "Open Vouchers"
.HTMLBody = BuildEmailBody(statusWS, addresses(emailAddr))
'--- send it now
' (if you want to send it later, you have to
' keep track of all the emails you create)
'.Send
End With
Next emailAddr
End Sub
Sub PrepareData(ByRef ws As Worksheet)
With ws
.Rows("1:6").Delete
.Range("A1:N1").AutoFilter
.AutoFilter.Sort.SortFields.Clear
.AutoFilter.Sort.SortFields.Add2 Key:=Range("A1"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortTextAsNumbers
With .AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'.Rows("2:5").Delete Shift:=xlUp
.Range("i2") = "Yes"
'--- it only makes sense to find the last row after all the
' other prep and deletions are complete
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("I2").AutoFill Destination:=Range("I2:I" & lastRow)
End With
End Sub
Function GetEmailAddresses(ByRef ws As Worksheet) As Dictionary
Dim addrs As Dictionary
Set addrs = New Dictionary
With ws
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'--- each entry in the dictionary is keyed by the email address
' and the item value is a CSV list of row numbers
Dim i As Long
For i = 2 To lastRow
Dim toAddr As String
toAddr = .Cells(i, TOADDR_COL).Value
If addrs.Exists(toAddr) Then
Dim theRows As String
theRows = addrs(toAddr)
addrs(toAddr) = addrs(toAddr) & "," & CStr(i)
Else
addrs.Add toAddr, CStr(i)
End If
Next i
End With
Set GetEmailAddresses = addrs
End Function
Function BuildEmailBody(ByRef ws As Worksheet, _
ByRef rowNumbers As String) As String
Const body1 As String = "<Font face = TimesNewRoman p style=font-size:18.5px color = " & _
"#0033CC)"
Const body2 As String = "<Font face = TimesNewRoman p style=font-size:18.5px color = " & _
"#0033CC)<br><br>You are receiving this email because our " & _
"records show you have vouchers open as follows: "
Const body3 As String = "<B><br><br>Please reply to this email with any questions." & _
"<br><br>***If we do not receive a reply from you within " & _
"the next 30 days, you will not be paid.<br><br>"
With ws
Dim rowNum As Variant
rowNum = Split(rowNumbers, ",")
Dim body As String
body = body1 & TimeOfDayGreeting & .Cells(rowNum(LBound(rowNum)), NAME_COL) & "," & body2
Dim i As Long
For i = LBound(rowNum) To UBound(rowNum)
body = body & "<br><br>Voucher #: " & .Cells(rowNum(i), VOUCHER_COL)
body = body & "<br>Check Date: " & Format(.Cells(rowNum(i), DATE_COL), "dd-mmm-yyyy")
body = body & "<br>Check Amount: " & Format(.Cells(rowNum(i), AMT_COL), "$#,##0.00")
Next i
End With
body = body & body3 & EmailSignature
BuildEmailBody = body
End Function
Function EmailSignature() As String
' Dim sigCheck As String
' sigCheck = Environ("appdata") & "\Microsoft\Signatures\Uncashed Checks.htm"
'
' If Dir(sigCheck) <> vbNullString Then
' EmailSignature = GetBoiler(sigString)
' Else
EmailSignature = vbNullString
' End If
End Function
Function TimeOfDayGreeting() As String
Select Case Time
Case 0.25 To 0.5
TimeOfDayGreeting = "Good morning "
Case 0.5 To 0.71
TimeOfDayGreeting = "Good afternoon "
Case Else
TimeOfDayGreeting = "Good evening "
End Select
End Function
Public Function OutlookIsRunning() As Boolean
'--- quick check to see if an instance of Outlook is running
Dim msApp As Object
On Error Resume Next
Set msApp = GetObject(, "Outlook.Application")
If Err > 0 Then
'--- not running
OutlookIsRunning = False
Else
'--- running
OutlookIsRunning = True
End If
End Function
Public Function AttachToOutlookApplication() As Outlook.Application
'--- finds an existing and running instance of Outlook, or starts
' the application if one is not already running
Dim msApp As Outlook.Application
On Error Resume Next
Set msApp = GetObject(, "Outlook.Application")
If Err > 0 Then
'--- we have to start one
' an exception will be raised if the application is not installed
Set msApp = CreateObject("Outlook.Application")
End If
Set AttachToOutlookApplication = msApp
End Function
I have a list of vendors that I sort by name and then have a macro go through and pull out data pieces from fields and place them inside an Outlook email. Pretty straightforward until I get to vendors with multiple lines, as I then need to have the code know to look at all the lines for that vendor and pull their info and place it into a list in the email (so they do not get multiple emails all at once).
The above image is a sample of the list after I have sorted it by vendor. So I would want one email for each vendor, but vendor1 would need the data from Invoice, Paid Amt, Check ID, and Check Dt for both of his lines. Vendor 2 would just have one line, and Vendor3 would have 3. I need a way to have the macro know to look at the vendor name (or Vendor #) and know that it needs to pull the data from the next line and include it in that same email until it is at the next vendor.
I am not a programmer and am trying to make this work. Below is an example of what I have been trying so far but it only creates one email for every line. Hoping someone smarter than me can help me. Thanks.
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strDir As String
Dim strFilename As String
Dim sigString As String
Dim strbody As String
Dim strname As String
Dim strName1 As String
Dim strDept As String
Dim strName2 As String
Dim lr As Long
Dim oItem As Object
Dim dteSat As Date
Dim nextSat As Date
Dim lastRow As Long
Dim ws As String
'Link to Outlook, use GetBoiler function to pull email signature
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Uncashed Checks.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Select Case Time
Case 0.25 To 0.5
GreetTime = "Good morning"
Case 0.5 To 0.71
GreetTime = "Good afternoon"
Case Else
GreetTime = "Good evening"
End Select
'Define the date for the next Saturday
With Item
K = Weekday(TODAY)
dteChk = Weekday(TODAY) - 30
dteSat = Now() + (10 - K)
nextSat = Date + 7 - Weekday(Date, vfSaturday)
End With
'Select the currently active sheet and insert a column next to column I, then fill it with the word 'yes'. The yes values will act as triggers to tell the code to run for that row.
'Delete first 7 rows of report. Find the Paid Amt header and then replace that column with a re-formatted one that shows the full numbers with decimals and zeroes. Change column E
'to UPPER case using the index and upper functions.
lr = ActiveSheet.UsedRange.Rows.Count
lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Rows("1:7").Select
Columns("C").SpecialCells(xlBlanks).EntireRow.Delete
Columns("I:I").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Set rng8 = Range("A1:Z1").Find("Paid Amt")
Set rng9 = ActiveSheet.Range(rng8, ActiveSheet.Cells(Rows.Count, rng8.Column).End(xlUp).Address)
rng9.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.FormulaR1C1 = "=TEXT(RC[+1],""#.00"")"
ActiveCell.Copy
Range(ActiveCell.Offset(350 - ActiveCell.Row, 0), ActiveCell.Offset(1, 0)).Select
ActiveSheet.Paste
ActiveCell.Offset.Resize(1).EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset.Resize(1).EntireColumn.Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToRight
Range("i2") = "Yes"
Range("I2").AutoFill Destination:=Range("I2:I" & lr)
[e2:e350] = [INDEX(UPPER(e2:e350),)]
'Begin a loop that looks at all the yes values in column I and then begins to create emails. Define the columns to be used for data by looking for the header names such as Paid Amt.
For Each cell In Columns("G").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "I").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
Set rng8 = Range("A1:Z1").Find("Paid Amt")
Set foundCell = Cells(cell.Row, rng8.Column)
Set rng9 = Range("A1:AG1").Find("Check Dt")
Set foundCell1 = Cells(cell.Row, rng9.Column)
Set rng12 = Range("A1:AG1").Find("Student Perm Address")
Set foundcell2 = Cells(cell.Row, rng12.Column)
'Create the actual email data, definiing the body and recipients/names, etc, based on the values in the cells noted below. Sentonbehalf is the 'From' field. Change font color
'using the hexadecimal codes. The one used here 1F497D is Blue-Gray.
With OutMail
strname = Cells(cell.Row, "A").Value
strName2 = Trim(Split(strname, ",")(1))
strName3 = Cells(cell.Row, "R").Value
strName4 = Cells(cell.Row, "E").Value
strbody = "<Font face = TimesNewRoman p style=font-size:18.5px color = #0033CC)<br><br>You are receiving this email because you have an uncashed check that was sent to you over 30 days ago. " & _
"Please cash or deposit your check.<br><br>" & _
"<B>The amount of the check is $" & foundCell & " and is dated " & foundCell1 & ". The check was mailed to the following address: <br><br>" & _
"<ul>" & foundcell2 & "<br></B></ul>"
.SentOnBehalfOfName = "accounts-payable#salemstate.edu"
.To = cell.Value
.Subject = "Uncashed Check from Salem State University"
.HTMLBody = "<Font face = TimesNewRoman p style=font-size:26.5px color = #0033CC><B>" & "Important Information Regarding Your Student Account </B><br><br><p style=font-size:18.5px> Dear " & strName2 & ", " & strbody & "<br>" & signature & "<HTML><BODY><IMG src='C:\Users\gmorris\Pictures\Saved Pictures\220px-Salem_State_University_logo.png' /></BODY></HTML>"
.display 'Or use Send
End With
Set OutMail = Nothing
End If
Next cell
End Sub
If the email addresses are sorted:
When the email address matches the previous:
Bypass creating email, append to the body.
When there is a new email address:
Send the existing mail before creating new email.
Option Explicit
Sub oneEmail_SortedEmailAddresses()
Dim OutApp As Object
Dim OutMail As Object
Dim strVoucher As String
Dim lr As Long
Set OutApp = CreateObject("Outlook.Application")
lr = ActiveSheet.UsedRange.Rows.Count
Dim toAddress As String
Dim i As Long
Dim refundDescYes As Boolean
For i = 2 To lr
' Email address
If ActiveSheet.Range("N" & i).Value <> "" Then
' One email per email address
' This assumes the addresses are sorted
If ActiveSheet.Range("N" & i).Value <> toAddress Then
If Not OutMail Is Nothing Then
If refundDescYes = True Then
OutMail.display
Else
OutMail.Close 1 ' olDiscard
End If
End If
toAddress = ActiveSheet.Range("N" & i).Value
Debug.Print toAddress
Set OutMail = Nothing
refundDescYes = False
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = toAddress
.Subject = "Uncashed Check from Salem State University"
End With
End If
' Refund Desc
If ActiveSheet.Range("I" & i).Value = "Yes" Then
refundDescYes = True
' Voucher
strVoucher = Cells(i, "D").Value
With OutMail
.HTMLBody = .HTMLBody & "<br>" & strVoucher & "<br>"
End With
End If
End If
Next
If Not OutMail Is Nothing Then
If refundDescYes = True Then
OutMail.display
Else
OutMail.Close 1 ' olDiscard
End If
End If
Set OutMail = Nothing
Debug.Print "Done."
End Sub
I have a macro attached to a shared file which I scheduled to run every day. It doesn't save the workbook on completion.
I believe this is because the shared document opens in read only mode.
The macro searches cell values and if they meet the relevant conditions, the cell is highlighted red and the text inside the cell is replaced. The macro is set to save at the end.
Public Sub SendEmailReminder2()
Dim lSecurity As Long
lSecurity = Application.AutomationSecurity
'so the workbook doesn't open in protected view
Application.AutomationSecurity = msoAutomationSecurityLow
Dim x As Long
Dim c As Range
Dim OutApp As Object
Dim strbody As String
Dim wb As Workbook
Set wb = Workbooks.Open("insert file path")
Set c = Range("C2")
'loop while cell is not empty
Do While Len(c.Value) > 0
If c.Value <= Date - 45 Then
c.Interior.Color = vbRed
c.Offset(0, -1).Interior.Color = vbRed
c.Offset(0, -2).Interior.Color = vbRed
c.Value = "Email Sent " & Date
'build the message
strbody = strbody & vbCrLf & c.Offset(0, -2) & " - " & _
c.Offset(0, -1) & " needs to be removed from New Releases"
End If
Set c = c.Offset(1, 0) 'next cell
Loop
Set OutApp = CreateObject("Outlook.Application")
On Error Resume Next
With OutApp.CreateItem(0)
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Body = strbody
.Send 'or use .Send
End With
On Error GoTo 0
Set OutApp = Nothing
Application.DisplayAlerts = False
wb.Save
Application.DisplayAlerts = True
Application.AutomationSecurity = lSecurity
End Sub
Try accessing the relevant parameters in the .Open method (full list of parameters found here)
Dim fn As String
fn = "insert file path"
Set wb = Workbooks.Open(Filename:=fn, _
ReadOnly:=False, _
IgnoreReadOnlyRecommended:=True)
I wrote code to send automated birthday emails using Outlook and PPT. My code was working fine for a while and was getting the result as expected. All of the sudden, I started getting error 91 and debugging tool points to the line, where the PPT closes.
myDOBPPT.Close
I have declared the PPT and assigned a destination path for my template.
Any clues or solution on why this is occurring all of a sudden?
Option Explicit
Private Sub Btn_SendEmail_Click()
'Declaring Outlook
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
'Declaring Sender Outlook
Dim SenderOutlookApp As Outlook.Application
Dim SenderOutlookMail As Outlook.MailItem
'Declaring PPT
Dim objPPT As PowerPoint.Application
Dim myDOBPPT As PowerPoint.Presentation
Dim DestinationPPT As String
'Assigning Path of files
DestinationPPT = "C:\Users\charles.hill\Desktop\BirthdayAutomation\Birthday_Automation.pptx"
'Declaring and assigning values for varibales
Dim i As Long
i = 2
Dim randomslidenumber As Integer
Dim FirstSlide As Double
Dim LastSlide As Double
Dim Mydate As Date
Mydate = Date
'Declaring the Logo Image
Dim LogoImage As String
'Assigning Path of files
LogoImage = "C:\Users\charles.hill\Pictures\Saved Pictures\TIGA Logo.jpg"
'Worksheets("Emp_Details").Range("A2:A" & Range("A2").End(xlDown).Row).ClearContents
Application.ScreenUpdating = False
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Set myDOBPPT = objPPT.Presentations.Open(DestinationPPT) 'PPT with birthday images opens
If Mydate = DateSerial(Year(Date), Month(Cells(i, 4).Value), Day(Cells(i, 4).Value)) Then
'Jump to Random Slide
With myDOBPPT
FirstSlide = 1
LastSlide = myDOBPPT.Slides.Count
Randomize
randomslidenumber = Int(((LastSlide - FirstSlide) * Rnd() + FirstSlide))
End With
With myDOBPPT.Slides(randomslidenumber)
.Shapes("NameOval").TextEffect.Text = WorksheetFunction.Proper(Sheet1.Cells(i, "B").Value) 'Employee's Name
.Shapes("DOB").TextEffect.Text = VBA.Format(Sheet1.Cells(i, "D").Value, "DD Mmm") 'Employee's DOB
.Export (ActiveWorkbook.Path & "\slide") & ".gif", "gif"
End With
Set OutlookApp = New Outlook.Application
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
OutlookMail.To = Cells(i, 5).Value
OutlookMail.CC = Cells(i, 6).Value
OutlookMail.BCC = ""
OutlookMail.Subject = "Happy Birthday " & Cells(i, 2).Value & "!!"
OutlookMail.Attachments.Add (ActiveWorkbook.Path & "\slide.gif")
OutlookMail.HTMLBody = "Good Morning All" & "<br> <br>" & _
"Please join TIGA in wishing " & Cells(i, 2).Value & " " & Cells(i, 3).Value & " a Happy Birthday! Hope you have a fantastic day" & "<br> <br>" & _
"<center><img src='cid:slide.gif' height='576' width='768'/></center>" & "<br> <br>" & _
"Best Wishes and Regards," & "<br>" & "HR Team" & "<br> <br>" & _
"<img src='C:\Users\charles.hill\Pictures\Saved Pictures\TIGA Logo.jpg'/>"
OutlookMail.Display
OutlookMail.Send
'Updates Email Sent column to Yes
With Worksheets("Emp_Details").Cells(i, 7)
.Value = "Yes"
End With
End If
Next i
myDOBPPT.Close
Set myDOBPPT = Nothing
objPPT.Quit
Set objPPT = Nothing
Set OutlookMail = Nothing
Set OutlookApp = Nothing
On Error Resume Next
VBA.Kill (ActiveWorkbook.Path & "\slide.gif")
ActiveWorkbook.Save
MsgBox "Processing Done", vbInformation
MsgBox "Records Updated and Workbook saved", vbInformation
'Declaring variables for updating Email sent column and send birthday wishes log.
Dim RowNum As Integer
RowNum = 2
Dim CurrentDate As Date
CurrentDate = Date
Dim Last_Row
Dim xInspect As Object
Dim PageEditor As Object
Const wdFormatPlainText = 0
'Worksheets("Sheet1").Range("G2:G500").ClearContents
'For RowNum = 2 To Cells(Rows.Count, 1).End(xlUp).Row
' If Worksheets("Sheet1").Cells(RowNum, 4).Value = CurrentDate Then
' Worksheets("Sheet1").Cells(RowNum, 7).Value = "Yes"
'End If
'Next RowNum
'ActiveWorkbook.Save
'MsgBox "Records Updated and Workbook saved", vbInformation
Set SenderOutlookApp = New Outlook.Application
Set SenderOutlookMail = SenderOutlookApp.CreateItem(olMailItem)
Set xInspect = SenderOutlookMail.GetInspector
Set PageEditor = xInspect.WordEditor
Last_Row = Worksheets("Emp_Details").Range("A" & Rows.Count).End(xlUp).Row
Worksheets("Log").Range("A2:I500").ClearContents
For RowNum = 2 To Last_Row
If Worksheets("Emp_Details").Cells(RowNum, "G").Value = "Yes" Then
Worksheets("Emp_Details").Rows(RowNum).Copy Destination:=Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
Next RowNum
Worksheets("Log").UsedRange.Copy
With SenderOutlookMail
.To = "sreenandini.jayaram#tiga.us"
.CC = ""
.BCC = ""
.Subject = "Birthday Wishes Log" & " " & Date
.Body = "Birthday wishes were sent out to the following Employees" & vbCrLf
.Display
PageEditor.Application.Selection.Start = Len(.Body)
PageEditor.Application.Selection.End = PageEditor.Application.Selection.Start
PageEditor.Application.Selection.PasteAndFormat Type:=wdFormatPlainText
.Display
.Send
Set PageEditor = Nothing
Set xInspect = Nothing
End With
Set SenderOutlookMail = Nothing
Set SenderOutlookApp = Nothing
Application.ScreenUpdating = True
End Sub 'Ending Button Click Sub-routine
You are getting that error because you are initializing the object inside the loop and trying to close it outside the loop. If the code doesn't enter the loop then myDOBPPT will be Nothing
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'
'
'
Set myDOBPPT = objPPT.Presentations.Open(DestinationPPT)
'
'
'
Next i
myDOBPPT.Close
You can also test it by changing myDOBPPT.Close to the below.
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'
'
'
Set myDOBPPT = objPPT.Presentations.Open(DestinationPPT)
'
'
'
Next i
If myDOBPPT Is Nothing Then
MsgBox "myDOBPPT is nothing"
End If
Move it inside the loop
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'
'
'
Set myDOBPPT = objPPT.Presentations.Open(DestinationPPT)
'
'
'
myDOBPPT.Close
Next i
I have this sample sheet:
My code currently goes through and creates emails based on the name in column H. So Approver1 gets one email for all his people. I have gotten it to de-dupe any repeats of their employee names. Example: Approver 1 gets an email that says 'please approve time for all of your employees below:' and then there is a list of names...Sample1, Sample2, and Sample3. The sheet will often have dupe employees for each approver, as shown in my sheet above.
The code works well for the first set of dupe names (there could be up to 10 of the same Approvers in a row, all getting one email), then runs fine through any singles.
When it hits the next set of repeated approvers it skips the first row in that group, then creates emails for every other division; so it skips a row until it gets to the end of the dupe approver section. So from the sheet, approver1 would get his email all set, then approver2 would get hers, but then approver3 becomes a mess.
How do I get this to loop correctly through an entire list, creating one email for each approver, with all the corresponding names of their people listed only once?
Sub DivisionApprovals()
Dim OutApp As Object
Dim OutMail As Object
Dim cell, lookrng As Range
Dim strdir As String
Dim strFilename As String
Dim sigString As String
Dim strBody As String
Dim strName As Variant
Dim strName1 As Variant
Dim strDept As Variant
Dim strName2 As String
Dim strbody2 As String
Dim strName3 As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set rng = ActiveSheet.UsedRange
r = 2
Do While r <= rng.rows.count
Set OutMail = OutApp.CreateItem(0)
Set strName = rng.Cells(r, 1)
Set strName3 = rng.Cells(r, 3)
strName2 = Trim(Split(strName, ",")(1))
strBody = "<Font Face=calibri>Dear " & strName2 & ", <br><br> Please approve the following divisions:<br><br>"
With OutMail
.To = rng.Cells(r, 2).Value
.Subject = "Please Approve Divisions"
List = strName3 & "<br>"
Do While rng.Cells(r, 1).Value = rng.Cells(r + 1, 1)
r = r + 1
Set strDept = rng.Cells(r, 3)
.Subject = "Approvals Needed!"
List = .HTMLBody & strDept & "<br>"
r = r + 1
.HTMLBody = List
Loop
.HTMLBody = strBody & "<B>" & List & "</B>" & "<br>" & Signature
.Display
End With
Set OutMail = Nothing
r = r + 1
Loop
Set OutApp = Nothing
End Sub
I deleted the previous answer, then un-deleted it in case you need that info. So as to not confuse anyone, the answer building from the OP's code is below.
DISCLAIMER: I am not a fan of the incrementing code style in the Do While, it make sit very difficult to chase errors but I understand the intention. I have included code below this in the way that my brain works and perhaps better coding style, you be the judge.
Alright #learningthisstuff I figured out what was going on, the code assumes the names are sorted. One thing not provided for is if the dept names are the same it will be listed multiple times, are the dept always unique for a person (no dupes?) if there are dupes that is different code.
This code works I just ran it as a macro on a dummy set. Big thing was the sort AND the incrementing logic, I changed a few things to make it more readable/understandable along the way.
I hope this helps you and you can modify as things change for you.
Sub Email_Macro()
'
' Email_Macro Macro
'
Dim OutApp As Object
Dim OutMail As Object
Dim cell, lookrng As Range
Dim strdir As String
Dim strFilename As String
Dim sigString As String
Dim strBody As String
Dim strName As Variant
Dim strName1 As Variant
Dim strDept As Variant
Dim strName2 As String
Dim strbody2 As String
Dim strName3 As Variant
Dim emailWS As Worksheet
Dim nameCol As Double
Dim deptCol As Double
Dim lastRow As Double
Dim startRow As Double
Dim r As Double
Dim depList As String
deptList = ""
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set emailWS = ThisWorkbook.ActiveSheet
startRow = 2 ' starting row
nameCol = 1 'col of name
deptCol = 3 'col of dept
'find the last row with a name in it from the name column
lastRow = emailWS.Cells(emailWS.Rows.Count, nameCol).End(xlUp).Row
'set variable to the starting row #
r = startRow 'this is where the counting begins
'sort the data first before going through the email process
'assumes these are the only columns 1 (nameCol) thru 3 (deptCol) to sort
'assumes you are sorting based on col 1 (nameCol)
emailWS.Range(Cells(startRow, nameCol), Cells(lastRow, deptCol)).Sort key1:=emailWS.Range(Cells(startRow, nameCol), Cells(lastRow, nameCol))
Do While r <= lastRow
Set OutMail = OutApp.CreateItem(0)
Set strName = emailWS.Cells(r, nameCol)
Set strName3 = emailWS.Cells(r, deptCol)
'careful the line below assumes there is always a comma separator in the name
strName2 = Trim(Split(strName, ",")(1))
strBody = "<Font Face=calibri>Dear " & strName2 & ", <br><br> Please approve the following divisions:<br><br>"
With OutMail
.To = emailWS.Cells(r, 2).Value
.Subject = "Please Approve Divisions"
deptList = strName3 & "<br>"
Do While emailWS.Cells(r, 1).Value = emailWS.Cells(r + 1, 1)
r = r + 1
Set strDept = emailWS.Cells(r, 3)
.Subject = "Approvals Needed!"
deptList = deptList & strDept & "<br>"
Loop
.HTMLBody = strBody & "<B>" & deptList & "</B>" & "<br>" & Signature
.Display
End With
Set OutMail = Nothing
'conditionally increment the row based on the name difference
If emailWS.Cells(r, 1).Value <> emailWS.Cells(r + 1, 1) Then
r = r + 1 'increment if there is a new name or no name
deptList = "" 'reset the department list
Else 'Do nothing
End If
Loop
Set OutApp = Nothing
End Sub
Screenshot:
To prove that I don't throw out comments without backing it up with some solution / mentoring? This is much easier for me to understand and troubleshoot. It steps through the rows in a very predictable fashion and we handle each row based on specified conditions. I also try and use variable names that will let you know what they are for.
Sub Email_Macro()
'
' Email_Macro Macro
'
Dim OutApp As Object 'email application
Dim OutMail As Object 'email object
Dim strBody As String 'first line of email body
Dim strName As String 'name in the cell we are processing
Dim strDept As String 'dept of the name we are processing
Dim previousName As String 'previous name processed
Dim nextName As String 'next name to process
Dim emailWS As Worksheet 'the worksheet selected wehn running macro
Dim nameCol As Double 'column # of names
Dim deptCol As Double 'column # of depts
Dim lastRow As Double 'last row of data in column
Dim startRow As Double 'row we wish to start processing on
Dim r As Double 'loop variable for row
'This will be the list of departments, we will build it as we go
Dim depList As String
Dim strSig As String 'email signature
strSig = "Respectfully, <br> Wookie"
deptList = "" 'empty intitialization
previousName = "" 'empty intialization
nextName = "" 'empty intialization
'Turn off screen updating
'Application.ScreenUpdating = False
'choose email application
Set OutApp = CreateObject("Outlook.Application")
'set worksheet to work on as active (selected sheet)
Set emailWS = ThisWorkbook.ActiveSheet
startRow = 2 ' starting row
nameCol = 1 'col of names, can also do nameCol = emailWS.Range("A1").Column
deptCol = 3 'col of depts, can also do deptCol = emailWS.Range("A3").Column
'** Advantage of the optional way is if you have many columns and you don't want to count them
'find the last row with a name in it from the name column
lastRow = emailWS.Cells(emailWS.Rows.Count, nameCol).End(xlUp).Row
'sort the data first before going through the email process using Range sort and a key
'assumes these are the only columns 1 (nameCol) thru 3 (deptCol) to sort
'assumes you are sorting based on col 1 (nameCol)
emailWS.Range(Cells(startRow, nameCol), Cells(lastRow, deptCol)).Sort key1:=emailWS.Range(Cells(startRow, nameCol), Cells(lastRow, nameCol))
'Set up our loop, it will go through every cell in the column we select in the loop
For r = startRow To lastRow
'Get the name and dept
'For the name we will split around the comma and take the second part of array (right of comma)
strName = Trim(Split(emailWS.Cells(r, nameCol), ",")(1))
strDept = emailWS.Cells(r, deptCol)
'if the next name is not blank (EOF)
If emailWS.Cells(r + 1, nameCol) <> "" Then
'assign the next name
nextName = Trim(Split(emailWS.Cells(r + 1, nameCol), ",")(1))
Else
'this is your EOF exit so assume a name
nextName = "Exit"
End If 'Else do noting on this If
If strName <> previousName Then
'Set our "new" name to previousName for looping
'process the "new" name
previousName = strName
'create the email object
Set OutMail = OutApp.CreateItem(0)
'Process as new email
With OutMail
.To = strName 'address email to the name
.Subject = "Please Approve Divisions" 'appropriate subject
deptList = strDept & "<br>" 'add the dept to dept list
'Build the first line of email body in HTML format
strBody = "<Font Face=calibri>Dear " & strName & ", <br><br> Please approve the following divisions:<br><br>"
End With
Else
'The name is the same as the email we opened
'Process Dept only by adding it to string with a line break
deptList = deptList & strDept & "<br>"
End If
'Do we send the email and get ready for another?
If strName <> nextName Then
'the next name is not the same as the one we are processing and we sorted first
'so it is time to send the email
OutMail.HTMLBody = strBody & "<B>" & deptList & "</B>" & "<br><br>" & strSig
OutMail.Display
Else 'Do Nohing
End If
Next r 'move to the next row
'nullify email reference
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
If you want to guard against duplicate departments then I would do it like this, you can see where this goes there is only one end with:
End With
Else
'The name is the same as the email we opened
'Process Dept only by adding it to string with a line break
If InStr(deptList, strDept) = 0 Then
'Dept is not in the list so Add the department
deptList = deptList & strDept & "<br>"
Else
'Do nothing, the dept is already there
End If
End If
I suppose never give up. Everything is possible, maybe just outside of our current skillset (so get some help and keep learning).
Cheers - WWC
If you pivot your data, here is a way to loop through the pivot to get unique information by name.
Pivotted Data
Code
Option Explicit
Sub LoopPivot()
With Sheet1
Dim pt As PivotTable
Set pt = .PivotTables(1)
Dim nameField As PivotField
Set nameField = pt.PivotFields("Name")
Dim nameItem As PivotItem
For Each nameItem In nameField.PivotItems
Dim name As String
name = nameItem.Value
Dim emailField As PivotField
Set emailField = pt.PivotFields("email")
Dim emailItem As PivotItem
Set emailItem = emailField.PivotItems(nameItem.Position)
Dim email As String
email = emailItem.Value
Dim divisionName As Range
Dim division As String
division = vbNullString
For Each divisionName In nameItem.DataRange
division = division & "," & divisionName.Value
Next
division = Mid(division, 2, 255)
Debug.Print name
Debug.Print email
Debug.Print division
Next
End With
End Sub
Here is a little helper stub I use to find a unique list from column A and place that list in column C. Based on a button click. Modify as you wish.
Option Explicit
Private Sub CommandButton1_Click()
Dim thisWS As Worksheet
Dim firstRow As Double
Dim lastRow As Double
Dim workCol As Double
Dim dataRange As Range
Dim uniqueLast As Double
Dim uniqueCol As Double
Dim i As Double
Dim y As Double
Dim Temp As String
Dim found_Bool As Boolean
Set thisWS = ThisWorkbook.Worksheets("Sheet2")
workCol = thisWS.Range("A1").Column
firstRow = 1
uniqueLast = 1
uniqueCol = thisWS.Range("C1").Column
lastRow = thisWS.Cells(thisWS.Rows.Count, workCol).End(xlUp).Row
For i = firstRow To lastRow
Temp = Trim(UCase(thisWS.Range(Cells(i, workCol), Cells(i, workCol))))
Temp = Replace(Temp, "#", "")
found_Bool = False
For y = 1 To uniqueLast
If Temp = thisWS.Range(Cells(y, uniqueCol), Cells(y, uniqueCol)) Then
found_Bool = True
Else ' Do nothing
End If
Next y
If found_Bool = False Then
thisWS.Range(Cells(uniqueLast + 1, uniqueCol), Cells(uniqueLast + 1, uniqueCol)) = Temp
uniqueLast = uniqueLast + 1
Else
End If
Next i
End Sub
Once you do this you can lookup each name in the non unique column and get the appropriate dept for subject or other info.
What you want is really a pivot in VBA (name & dept(s), you could just vba the pivot, that is a little trickier but very doable.
'***************************************************
OK take what Scott has and its very workable. With regard to the pivot table itself a few "helpers". Again, either name the table and just update the range or delete it and make it each time. Do to the project I delete it every time here and keep using the same space to make picot after picot, every time the workbook is opened this scratch space is clear.
This is me creating a pivot of sales data, bear with me, I actually copy the pivot data afterwards to values and then add columns to perform calculations, then I move that to a report, deleting the pivot and working table, basically this all happens away from what the user gets to see when they click a button:
'***************************
'Add Sales Pivot Table
'Last DR is the last data row, you can see it done several times, in the code below, once you do it you will always do it
'CalcSheet is the name of the worksheet in the workbook I am working on
'The range here is defined in Range Format, you could use a named range or use .Range(Cells(row,col),Cells(row,col)) there are several ways
'I name the pivot table upon creation so I can manipulate it better
'I specify the target cell, upper left with which to begin the pivot table
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
CalcSheet.Range("K14:AY" & LastDR), Version:=xlPivotTableVersion15).CreatePivotTable _
TableDestination:=CalcSheet.Range("CA37"), TableName:="SalesPVT", DefaultVersion _
:=xlPivotTableVersion15
I set the pivot up in the format that I want and then I sort it based on one of the fields:
With CalcSheet.PivotTables("SalesPVT").PivotFields("Salesperson")
.Orientation = xlRowField
.Position = 1
End With
With CalcSheet.PivotTables("SalesPVT").PivotFields("Customer")
.Orientation = xlRowField
.Position = 2
End With
With CalcSheet.PivotTables("SalesPVT").PivotFields("DD Rev")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "$#,##0"
End With
With CalcSheet.PivotTables("SalesPVT").PivotFields("Job Days")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0"
End With
CalcSheet.PivotTables("SalesPVT").PivotFields("Salesperson").AutoSort _
xlDescending, "Sum of DD Rev"
Perhaps there is another way but now I do not know the dimensions of the pivot table (rows) do I? So I define them here based on the first column where I placed the pivot table and the anchor range I specified in creation:
'Find the last row of Pivot table Data
Dim LastPVTrow As Double
Dim FirstPVTrow As Double
Dim NumPVTrows As Double
Dim PivCol As Double
PivCol = CalcSheet.Range("CB37").Column
FirstPVTrow = CalcSheet.Range("CB37").Row
LastPVTrow = CalcSheet.Cells(Rows.Count, PivCol).End(xlUp).Row
NumPVTrows = LastPVTrow - FirstPVTrow
Here I make a column somewhere else based on the pivot data, your email could occur about right here if you wanted:
'make the Avg Rev/Job Day Column
For i = 1 To NumPVTrows ' four columns in this table
CalcSheet.Range("CD" & (100 + i)).NumberFormat = "$#,##0"
If CalcSheet.Range("CC" & (FirstPVTrow + i)) <> 0 Then
CalcSheet.Range("CD" & (100 + i)) = CalcSheet.Range("CB" & (FirstPVTrow + i)) / CalcSheet.Range("CC" & (FirstPVTrow + i))
Else
CalcSheet.Range("CD" & (100 + i)) = 0
End If
Next i
'Here I am going to leave a bunch of stuff out but it puts headers on my table that is only missing the pivot and adds some more columns and calculations, counts the values based on specified ranges etc and finds averages
'Then I copy the pivot table and delete it, happens every time a button is clicked and a new workbook is selected to process
'copy pivot table to get rid of it
CalcSheet.PivotTables("SalesPVT").TableRange1.Copy
'Paste it as values with formatting
CalcSheet.Range("CA100").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Delete Sales Pivot from the file
CalcSheet.PivotTables("SalesPVT").TableRange1.Delete
'Clear Work Space
CalcSheet.Range("CA1:CN500").Clear
Once I have processed the sales persons, I do it again by customer in the same working scratch space, build a table make new columns and headers down below based on the data, copy the table as values and then after putting it into a report, delete it all, for the next go around. I format my little table before export: bolding the headers, putting grey on the sales person or the customer, the totals line is blue, I right align the numbers in the cell, there sis alot of code left out to focus on the pivot.
So here is similar pivot code building the table for customers
'***************************************
'Make the Customer Pivot and table
'***************************************
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
CalcSheet.Range("K14:AY" & LastDR), Version:=xlPivotTableVersion15).CreatePivotTable _
TableDestination:=CalcSheet.Range("CA37"), TableName:="CustPVT", DefaultVersion _
:=xlPivotTableVersion15
With CalcSheet.PivotTables("CustPVT").PivotFields("Customer")
.Orientation = xlRowField
.Position = 1
End With
With CalcSheet.PivotTables("CustPVT").PivotFields("DD Rev")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "$#,##0"
End With
With CalcSheet.PivotTables("CustPVT").PivotFields("Job Days")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0"
End With
'Find the last row of Pivot table Data
FirstPVTrow = CalcSheet.Range("CA37").Row
LastPVTrow = CalcSheet.Cells(Rows.Count, PivCol).End(xlUp).Row
'LastPVTrow = CalcSheet.Range("CB37:CB500").Find((0), LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
NumPVTrows = LastPVTrow - FirstPVTrow
etc. etc. etc . . .
I am sure the users on here are a lot more elegant.
I strive for code that is readable and usually understandable by me (hopefully others) and limited by my skillset, you have to come back to this stuff months or years later, trust me it looks different than when you are "living in the moment of creation" Take the time to leave yourself bread crumbs, name your variables and your tables so they make sense. Try an use named ranges rather than "hard coding" ranges, I know I did it here, do as I say . . . not as I do. I will usually only do this in areas that will later be erased and wiped. No excuses but I was moving in a rush on this one.
Cheers
I'm using a different technic to solve the same problem with Excel. First of all I have a Function to open a new ADODB-Recordset:
Function RST_Excel(strExceldatei As String, strArbeitsblatt As String, strWHERE As String, Optional strBereich As String, _
Optional strDatenfelder As String = "*") As ADODB.Recordset
Dim i As Integer
Dim rst As ADODB.Recordset
Dim strConnection As String
Dim strSQL As String
On Error GoTo sprFehler
strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & strExceldatei
If global_con Is Nothing Then
Set global_con = New ADODB.Connection
With global_con
.Open strConnection
End With
End If
strSQL = "SELECT " & strDatenfelder & " FROM [" & strArbeitsblatt & "$" & strBereich & "] WHERE " & strWHERE
Set rst = New ADODB.Recordset
With rst
.Source = strSQL
.CursorLocation = adUseClient
.ActiveConnection = global_con
.Open
Set RST_Excel = rst
End With
sprEnde:
Set rst = Nothing
Exit Function
sprFehler:
Set rst = Nothing
Set RST_Excel = Nothing
End Function
Then I open the ADODB-Recordset from another Routine:
Dim strWHERE As String
Dim strFields As String
Dim rst_Recipients As ADODB.Recordset
strWHERE = "Surname IS NOT NULL AND Emailadress IS NOT NULL"
strFields = "Surname, Name, Emailadress, SMIME"
Set rst_Empfänger = RST_Excel(ThisWorkbook.FullName, "Email", strWHERE, "A1:M1000", strFields)
As the query is passed as an SQL-Statement you could also pass an Statement to get unique results.
The advance for me is that I could easily move through the Recordset:
With rst
.movefirst
do until .eof
debug.print .fields("surename").value
.movenext
loop
end with
I think you can use this to do what you want to do.
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub