Forum Discussion
Help Fixing Macro - Issue Email Via Excel
Hi,
I have got a macro which successfully issues emails for another worksheet. I have tried to copy this to my new worksheet, however it appears to not be working. I have copied this onto the "SMR" and "High Risk Register" tabs. Extraction of the Module Macro is below:
Dim HighRiskRegister As Worksheet
Dim SMR As Worksheet
Dim OutMail As Object
Dim OutApp As Object
Sub btn_High_Risk_Register_send_email_clicked()
Set High_Risk_Register = ActiveWorkbook.Sheets("High Risk Register")
High_Risk_Register.CellsStartRow = 3
High_Risk_Register.CellsEndRow = High_Risk_Register.Cells.Cells(High_Risk_Register.Rows.Count, 4).End(xlUp).Row
For i = High_Risk_Register.CellsStartRow To High_Risk_Register.CellsEndRow
Dim mailSub As String
Dim mailBody As String
Dim email1 As String, email2 As String, email3 As String, email4 As String, email5 As String
Dim email6 As String, email7 As String, email8 As String, email9 As String, email10 As String
Dim emailTo As String
emailTo = ""
mailSub = High_Risk_Register.Cells(i, 15).Text
mailBody = High_Risk_Register.Cells(i, 16).Text
email1 = High_Risk_Register.Cells(i, 17).Text
email2 = High_Risk_Register.Cells(i, 18).Text
email3 = High_Risk_Register.Cells(i, 19).Text
email4 = High_Risk_Register.Cells(i, 20).Text
email5 = High_Risk_Register.Cells(i, 21).Text
email6 = High_Risk_Register.Cells(i, 22).Text
email7 = High_Risk_Register.Cells(i, 23).Text
email8 = High_Risk_Register.Cells(i, 24).Text
email9 = High_Risk_Register.Cells(i, 25).Text
email10 = High_Risk_Register.Cells(i, 26).Text
'Appending email1 to final email list
If email1 <> "0" Then
If emailTo = "" Then
emailTo = email1
Else
emailTo = emailTo & "," & email1
End If
End If
'Appending email2 to final email list
If email2 <> "0" Then
If emailTo = "" Then
emailTo = email2
Else
emailTo = emailTo & "," & email2
End If
End If
'Appending email3 to final email list
If email3 <> "0" Then
If emailTo = "" Then
emailTo = email3
Else
emailTo = emailTo & "," & email3
End If
End If
'Appending email4 to final email list
If email4 <> "0" Then
If emailTo = "" Then
emailTo = email4
Else
emailTo = emailTo & "," & email4
End If
End If
'Appending email5 to final email list
If email5 <> "0" Then
If emailTo = "" Then
emailTo = email5
Else
emailTo = emailTo & "," & email5
End If
End If
'Appending email6 to final email list
If email6 <> "0" Then
If emailTo = "" Then
emailTo = email6
Else
emailTo = emailTo & "," & email6
End If
End If
'Appending email7 to final email list
If email7 <> "0" Then
If emailTo = "" Then
emailTo = email7
Else
emailTo = emailTo & "," & email7
End If
End If
'Appending email8 to final email list
If email8 <> "0" Then
If emailTo = "" Then
emailTo = email8
Else
emailTo = emailTo & "," & email8
End If
End If
'Appending email9 to final email list
If email9 <> "0" Then
If emailTo = "" Then
emailTo = email9
Else
emailTo = emailTo & "," & email9
End If
End If
'Appending email10 to final email list
If email10 <> "0" Then
If emailTo = "" Then
emailTo = email10
Else
emailTo = emailTo & "," & email10
End If
End If
On Error Resume Next
' Sending Email with all the data collected
If emailTo <> "" Then
Call sendEmail(emailTo, mailSub, mailBody)
HighRiskRegister.Cells(i, 28) = "Sent"
End If
Next i
Set OutApp = Nothing
End Sub
Sub btn_SMR()
Set OutApp = CreateObject("Outlook.Application")
Set SMR = ActiveWorkbook.Sheets("SMR")
SMRStartRow = 3
SMRRow = SMR.Cells(SMR.Rows.Count, 4).End(xlUp).Row
For i = SMRStartRow To SMREndRow
Dim mailSub As String
Dim mailBody As String
Dim email1 As String, email2 As String, email3 As String, email4 As String, email5 As String
Dim email6 As String, email7 As String, email8 As String, email9 As String, email10 As String
Dim emailTo As String
emailTo = ""
mailSub = SMR.Cells(i, 18).Text
mailBody = SMR.Cells(i, 19).Text
email1 = SMR.Cells(i, 20).Text
email2 = SMR.Cells(i, 21).Text
email3 = SMR.Cells(i, 22).Text
email4 = SMR.Cells(i, 23).Text
email5 = SMR.Cells(i, 24).Text
email6 = SMR.Cells(i, 25).Text
email7 = SMR.Cells(i, 26).Text
email8 = SMR.Cells(i, 27).Text
email9 = SMR.Cells(i, 28).Text
email10 = SMR.Cells(i, 29).Text
'Appending email1 to final email list
If email1 <> "0" Then
If emailTo = "" Then
emailTo = email1
Else
emailTo = emailTo & "," & email1
End If
End If
'Appending email2 to final email list
If email2 <> "0" Then
If emailTo = "" Then
emailTo = email2
Else
emailTo = emailTo & "," & email2
End If
End If
'Appending email3 to final email list
If email3 <> "0" Then
If emailTo = "" Then
emailTo = email3
Else
emailTo = emailTo & "," & email3
End If
End If
'Appending email4 to final email list
If email4 <> "0" Then
If emailTo = "" Then
emailTo = email4
Else
emailTo = emailTo & "," & email4
End If
End If
'Appending email5 to final email list
If email5 <> "0" Then
If emailTo = "" Then
emailTo = email5
Else
emailTo = emailTo & "," & email5
End If
End If
'Appending email6 to final email list
If email6 <> "0" Then
If emailTo = "" Then
emailTo = email6
Else
emailTo = emailTo & "," & email6
End If
End If
'Appending email7 to final email list
If email7 <> "0" Then
If emailTo = "" Then
emailTo = email7
Else
emailTo = emailTo & "," & email7
End If
End If
'Appending email8 to final email list
If email8 <> "0" Then
If emailTo = "" Then
emailTo = email8
Else
emailTo = emailTo & "," & email8
End If
End If
'Appending email9 to final email list
If email9 <> "0" Then
If emailTo = "" Then
emailTo = email9
Else
emailTo = emailTo & "," & email9
End If
End If
'Appending email10 to final email list
If email10 <> "0" Then
If emailTo = "" Then
emailTo = email10
Else
emailTo = emailTo & "," & email10
End If
End If
On Error Resume Next
' Sending Email with all the data collected
If emailTo <> "" And SMR.Cells(i, 31) <> "Sent" Then
Call sendEmail(emailTo, mailSub, mailBody)
SMR.Cells(i, 31) = "Sent"
End If
Next i
Set OutApp = Nothing
End Sub
Sub sendEmail(emailTo As String, Subj As String, msg As String)
Application.DisplayAlerts = False
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = emailTo
.CC = ""
.BCC = ""
.Subject = Subj
.body = msg
.send
End With
On Error GoTo 0
Set OutMail = Nothing
Application.DisplayAlerts = True
End Sub
Is anyone able to help identify which cells I have updated incorrectly?
Many thanks,
1 Reply
- Charla74Iron Contributor
calof1 I would suggest that rather than running the code to use the 'step into' function from the macro window, then use the F8 key to step through each line of code to find any errors. Alternatively, from the VBA Editor, you can use the Debug / Compile VBA Project which will check the code and highlight errors.