Hi Everyone,
I'm creating a macro to pull data off a sheet, "Dashboard", and send it to team members. The email itself generates properly, but the macro runs constantly after I press the button, creating unlimited amounts of email drafts in Outlook until I exit Excel. The formula in VBA is below. Would anyone be able to help identify the reason for the macro running over and over?
Sub Send_Email_With_Signature()
Dim objOutApp As Object, objOutMail As Object
Dim strBody As String, strSig As String
Dim olMailItm As Object
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim rng As Range
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
'rws = ActiveSheet.UsedRange.Rows.Count
'cols = ActiveSheet.UsedRange.Columns.Count
'Set rng = Range(Cells(1, 1), Cells(rws, cols))
' rng.Select
'You can also use a fixed range if you want
Set rng = Sheets("Dashboard").Range("B21:H78").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
For iCounter = 1 To WorksheetFunction.CountA(Columns(1))
Set objOutApp = CreateObject("Outlook.Application")
Set objOutMail = objOutApp.CreateItem(0)
BDate1 = Cells(iCounter, 5).Value
BDate2 = Cells(iCounter, 6).Value
On Error Resume Next
With objOutMail
'SET THE EMAIL CONDITIONS
.To = ""
.CC = ""
.BCC = ""
.Subject = "Team Performance - " & BDate1 & " - " & BDate2 & ""
'CHECK NAMES, ENSURES INTERNAL EMAIL ADDRESSES EXISTS IN ADDRESS BOOK
.Recipients.ResolveAll
'DO NOT REMOVE - THIS MUST BE VISIBLE FIRST TO GET THE DEFAULT SIGNATURE
.Display
'GET THE HTML CODE FROM THE SIGNATURE
strSig = .HTMLBody
'WHAT SHOULD THE EMAIL SAY, ON TOP OF THE SIGNATURE
'HTML TAGS CAN BE INCLUDED HERE
strBody = ""
'strBody = "<font face=Tahoma size=3> This is what I want the email to say. </calibri> <p>" & _
'"<font color=green> For additional support, tips, or Excel consultation, " & _
'"please visit: <a href=http://www.formatcells.com> formatcells.com.</a></font>"
strBody = "<font face=Calibri size=3> Hi Team " & ", <p>" & _
"Below is our scorecard reporting for the timeframe listed above, including current and month to date snapshots. Please let me know if you have any questions." & vbCrLf
strBody = strBody & RangetoHTML(rng) & vbCrLf
strBody = strBody & strSig
'COMBINE THE EMAIL WITH THE SIGNATURE
.HTMLBody = strBody
'IF YOU DO NOT HAVE HTML IN THE BODY, USE THIS INSTEAD
'.Body = strBody & strSig
'AUTOMATICALLY SEND EMAIL (IT WILL STILL BRIEFLY POPUP)
'.Send
End With
On Error GoTo 0
Set objOutMail = Nothing
Set objOutApp = Nothing
Next
End Sub
