VBA Send E-Mail to each row e-mail address

[cortexnotion]

Hi All

I need to e-mail each e-mail address individually which is in row B. However I get a 'Next Without For error'

Could someone please check my code?

Thanks

Dim OutApp As Object, OutMail As Object
Dim UserRng As Variant, i As Long, LW3 As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

UserRng = ThisWorkbook.Sheets(3).Range("A2:D" & LR3).value
LW3 = "WE-" & Format(LW1, "dd-mm-yyyy")

If InStr(UserRng(i, 2), "error") = 0 Then
With OutMail
.SentOnBehalfOfName = [EMAIL]test@test.com[/EMAIL]
.To = UserRng(i, 2)
.Subject = "Updates: " & LW3 & " - Unapproved User"
.HTMLBody = "<p><span style=""font-family: Calibri; font-size: 11pt; background-color: #ffff00""><b>*** This is an automated e-mail from the Reporting Tool ***</b></span></p>" &
"<p><span style=""font-family: Calibri; font-size: 11pt"">Hi " & UserRng(i, 3) & "</span></p>" & _
"<p><span style=""font-family: Calibri; font-size: 11pt""><em>For" & LW3 & "you submitted asset updates but you are currently an Unapproved User" & _
"<p><span style=""font-family: Calibri; font-size: 11pt; background-color: #00ffff"">You are welcome to continue to use the Training Environment to practice your submissions but please note these will not be actioned.</span></p>" & _
"<p><span style=""font-family: Calibri; font-size: 11pt"">Kind Regards </span></p>" & _
"<p><span style=""font-family: Calibri; font-size: 11pt; color: #000080"">Data Team</span></p>"
.Display
End With

Next
End If
End Sub

 

[dave3009]

You don't have the start to your For loop.

For i = 2 to lastrow
'Your code
Next i

 

[cortexnotion]

Thank you @dave3009 - that sorted that out!

I now have an error "Subscript out of range"

If InStr(UserRng(i, 2), "error") = 0 Then

Any ideas?

Thanks

 

[dave3009]

It would be useful if you could post the entire code and an example of the UserRng data. I don't see any variable for LR3 or LW1 or where you set them. A short description of what the sub is supposed to do would also be useful

 

[cortexnotion]

Morning @dave3009

Once you get to the Outlook part, the code is to e-mail all users in column B, and copy in their Manager in column D and refer to their first name in column C. The code is working on up until where I try to refer to the Sheet(3) range.

Many thanks

Option Explicit
Option Compare Text

Sub UnapprovedUsers()

Select Case MsgBox("Unapproved Users Run will now take place. Would you like to continue?", vbYesNo + vbQuestion, "Unapproved Users Run")
Case vbNo
MsgBox "Unapproved Users Run cancelled.", vbExclamation, "Unapproved Users Run"
Exit Sub
End Select

Application.ScreenUpdating = False

Dim ArrIN As Variant, ArrOUT As Variant, Header As Variant, MasterList As Workbook
Dim LR1 As Long, LR2 As Long, LR3 As Long, LC1 As Long, LW1 As Long, LW2 As Long, a As Long, b As Long

Set MasterList = Workbooks.Open("S:\Operations\Master User List.xlsx")
LR1 = MasterList.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

ThisWorkbook.Sheets(2).Range("A1:A" & LR1).Value = MasterList.Sheets(1).Range("H1:H" & LR1).Value
ThisWorkbook.Sheets(2).Range("B1:B" & LR1).Value = MasterList.Sheets(1).Range("G1:G" & LR1).Value
ThisWorkbook.Sheets(2).Range("C1:C" & LR1).Value = MasterList.Sheets(1).Range("F1:F" & LR1).Value
ThisWorkbook.Sheets(2).Range("D1:D" & LR1).Value = MasterList.Sheets(1).Range("C1:C" & LR1).Value
ThisWorkbook.Sheets(2).Range("E1").Value = "Line Manager Email Address"
ThisWorkbook.Sheets(2).Range("E2:E" & LR1).Formula = "=LEFT($D2,FIND("" "",$D2)-1) & ""."" & TRIM(RIGHT(SUBSTITUTE($D2,"" "",REPT("" "",100)),100)) & ""@test.co.uk"""
MasterList.Close False

LR2 = ThisWorkbook.Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
ArrIN = ThisWorkbook.Sheets(1).Range("B3:AU" & LR2).Value

LW1 = Application.Evaluate("INT((TODAY()-1)/7)*7+1")
LW2 = LW1 - 30

On Error Resume Next
ThisWorkbook.Sheets(1).AutoFilterMode = False
On Error GoTo 0

ReDim ArrOUT(1 To LR2, 1 To 1)
    b = 1

    For a = LBound(ArrIN) To UBound(ArrIN)
If ArrIN(a, 3) >= LW2 And ArrIN(a, 3) <= LW1 Then

ArrOUT(b, 1) = Left(ArrIN(a, 9), 7)
b = b + 1

End If
Next a

With ThisWorkbook.Sheets(3)

LC1 = .Cells(1, Columns.Count).End(xlToLeft).Column

For Each Header In Array("User ID", "Email Address", "First Name", "Line Manager")
.Cells(1, LC1).Value = Header
LC1 = LC1 + 1
Next Header

.Range("A2").Resize(UBound(ArrOUT)).Value = ArrOUT
.Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes

LR3 = .Range("A" & Rows.Count).End(xlUp).Row

    .Range("B2:B" & LR3).Formula = "=IFERROR(INDEX(Sheet2!$B$2:$B$" & LR1 & ",MATCH($A2,Sheet2!$A$2:$A$" & LR1 & ",0)),""ERROR"")"
.Range("C2:C" & LR3).Formula = "=IFERROR(INDEX(Sheet2!$C$2:$C$" & LR1 & ",MATCH($A2,Sheet2!$A$2:$A$" & LR1 & ",0)),""ERROR"")"
.Range("D2:D" & LR3).Formula = "=IFERROR(INDEX(Sheet2!$E$2:$E$" & LR1 & ",MATCH($A2,Sheet2!$A$2:$A$" & LR1 & ",0)),""ERROR"")"

End With

Dim OutApp As Object, OutMail As Object
Dim UserRng As Variant, i As Long, LW3 As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

UserRng = ThisWorkbook.Sheets(3).Range("A2:D" & LR3).Value
LW3 = "WE-" & Format(LW1, "dd-mm-yyyy")

For i = 2 To LR3
If InStr(UserRng(i, 2), "error") = 0 Then
With OutMail
.SentOnBehalfOfName = "addeliverywater@severntrent.co.uk"
.To = UserRng(i, 2)
.CC = UserRng(i, 4)
.Subject = "Updates: " & LW3 & " - Unapproved User"
.HTMLBody = "<p><span style=""font-family: Calibri; font-size: 11pt; background-color: #ffff00""><b>*** This is an automated e-mail from the Reporting Tool ***</b></span></p>" & _
"<p><span style=""font-family: Calibri; font-size: 11pt"">Hi " & Cells(i, 3) & "</span></p>" & _
"<p><span style=""font-family: Calibri; font-size: 11pt"">We have noticed that you are currently submitting updates through the Training Environment. You are currently an Unapproved User " & _
"which means your updates do not enter the Live database.</span></p>" & _
"<p><span style=""font-family: Calibri; font-size: 11pt"">If you have completed training please ask the Super User who trained you to contact the Quality Team. " & _
"They will need to e-mail [EMAIL]x@x.co.uk[/EMAIL] with your Full Name and User ID, and confirm their approval for you to carry out asset updates in the Live database. " & _
"The Quality Team will process Approval requests within 5 Working Days.</span></p>" & _
"<p><span style=""font-family: Calibri; font-size: 11pt"">Alternatively, if you have not yet received training please ask your local Super User to arrange this for you.</span></p>" & _
"<p><span style=""font-family: Calibri; font-size: 11pt; background-color: #00ffff"">You are welcome to continue to use the Training Environment to practice your submissions but please note these are unmonitored.</span></p>" & _
"<p><span style=""font-family: Calibri; font-size: 11pt"">Kind Regards </span></p>" & _
"<p><span style=""font-family: Calibri; font-size: 11pt; color: #000080"">Management</span></p>"
.Display
'Application.Wait (Now + TimeValue("0:00:00"))
'Application.SendKeys "%s"
End With
End If
Next i

MsgBox WorksheetFunction.CountIf(ThisWorkbook.Sheets(3).Range("B2:B" & LR3), "error")

MsgBox "Unapproved Users Run complete.", vbInformation, "Unapproved Users Run"

Application.ScreenUpdating = True

End Sub