Forum Discussion

calof1's avatar
calof1
Iron Contributor
Jan 17, 2020

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

  • Charla74's avatar
    Charla74
    Iron 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.

Resources