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

cortexnotion

Board Regular
Joined
Jan 22, 2020
Messages
138
Office Version
  1. 2013
Platform
  1. Windows
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

VBA Code:
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
 

Some videos you may like

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

dave3009

Well-known Member
Joined
Jun 23, 2006
Messages
7,002
Office Version
  1. 365
  2. 2016
You don't have the start to your For loop.

Code:
For i = 2 to lastrow
'Your code
Next i
 

cortexnotion

Board Regular
Joined
Jan 22, 2020
Messages
138
Office Version
  1. 2013
Platform
  1. Windows
Thank you @dave3009 - that sorted that out!

I now have an error "Subscript out of range"

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

Any ideas?

Thanks
 

dave3009

Well-known Member
Joined
Jun 23, 2006
Messages
7,002
Office Version
  1. 365
  2. 2016
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

Board Regular
Joined
Jan 22, 2020
Messages
138
Office Version
  1. 2013
Platform
  1. Windows
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

VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,751
Messages
5,626,657
Members
416,199
Latest member
Gautamsunil

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top