VBA macro to email

[kyameizero]

I have a code that can send emails to the people that I want. The code sends emails based on the number "1" I placed in Column J. However, even if there are number 1s on 3 rows, the code only sends the email to the top person.

How do I make it so that the code will send to all rows which have a number "1" in Column J?
Help please

This is the code that I have:
Sub notify1()
Dim rng As Range
For Each rng In Range("J2:J24")
If (rng.Value = 1) Then
Call mymacro1
End If
Next rng
End Sub

Private Sub mymacro1()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Dim xRgName As Range
Dim xRgSend As Range
Dim xRgDate As Range
Dim xRgQual As Range
Dim xRgEPNo As Range
Dim xRgNameVal As String
Dim xRgSendVal As String
Dim xRgDateVal As String
Dim xRgQualVal As String
Dim xRgEPNoVal As String
Dim xMailSubject As String
Dim xLastRow As Long
On Error Resume Next

Set xOutApp = CreateObject("Outlook.Application")
Set xRgName = ActiveSheet.Range("B2:B24")
Set xRgDate = ActiveSheet.Range("G2:G24")
Set xRgSend = ActiveSheet.Range("H2:H24")
Set xRgQual = ActiveSheet.Range("E2:E24")
Set xRgEPNo = ActiveSheet.Range("D2:E24")

Set xRgName = xRgName(1)
Set xRgDate = xRgDate(1)
Set xRgSend = xRgSend(1)
Set xRgQual = xRgQual(1)
Set xRgEPNo = xRgEPNo(1)
xRgNameVal = xRgName.Value
xRgSendVal = xRgSend.Value
xRgDateVal = xRgDate.Value
xRgQualVal = xRgQual.Value
xRgEPNoVal = xRgEPNo.Value

Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Dear " & xRgNameVal & ", EP number: " & xRgEPNo & ", " & vbNewLine & vbNewLine & _
"Your " & xRgQualVal & " is expiring on " & xRgDateVal & vbNewLine & _
"Please renew your qualification as soon a possible."
xMailSubject = "Your " & xRgQualVal & " qualification is expiring soon!"

On Error Resume Next
With xOutMail
.To = xRgSendVal
.CC = ""
.BCC = ""
.Subject = xMailSubject
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub

 

[davesexcel]

You need to pass a variable to the called macro.
Place this code into a new module, run "Call Macro"
When 1 is found in column J, it will call the "NewMacro" and pass along the row number.

Test it out, then change your code accordingly.

Sub CalMacro()
    Dim c As Range
    Dim rng As Range
    Dim x As Integer
    Dim sh As Worksheet
    Set sh = ActiveSheet
    With sh
        Set rng = .Range("J2:J24")
        For Each c In rng.Cells
            If c = 1 Then
                x = c.Row
                Call NewMacro(x)
            End If
        Next c
    End With
End Sub

Private Sub NewMacro(x As Integer)
    Dim sh As Worksheet
    Dim xRgNameVal As String
    Dim xRgSendVal As String
    Dim xRgDateVal As String

    Set sh = ActiveSheet

    With sh
        xRgNameVal = .Cells(x, "B").Value
        xRgDateVal = .Cells(x, "G").Value
        xRgSendVal = .Cells(x, "H").Value
    End With

    MsgBox xRgNameVal & vbNewLine & xRgDateVal & vbNewLine & xRgSendVal

End Sub

 

[kyameizero]

Thanks, @davesexcel for trying to help me out!

I've changed my code accordingly and tested it out. However, I am still experiencing the same thing.
Does it matter if I have more than one sheet in my workbook? Do I need to declare which sheet I am on the code?
Or is it because I updated my code wrongly?

This is my updated code:
Sub notify1()
Dim c As Range
Dim rng As Range
Dim x As Integer
Dim sh As Worksheet
Set sh = ActiveSheet
With sh
Set rng = .Range("J2:J24")
For Each c In rng.Cells
If c = 1 Then
x = c.Row
Call NewMacro(x)
End If
Next c
End With
End Sub

Private Sub NewMacro(x As Integer)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Dim xRgName As Range
Dim xRgSend As Range
Dim xRgDate As Range
Dim xRgQual As Range
Dim xRgEPNo As Range
Dim xRgNameVal As String
Dim xRgSendVal As String
Dim xRgDateVal As String
Dim xRgQualVal As String
Dim xRgEPNoVal As String
Dim xMailSubject As String
Dim xLastRow As Long
On Error Resume Next

Set xOutApp = CreateObject("Outlook.Application")
Set xRgName = ActiveSheet.Range("B2:B24")
Set xRgDate = ActiveSheet.Range("G2:G24")
Set xRgSend = ActiveSheet.Range("H2:H24")
Set xRgQual = ActiveSheet.Range("E2:E24")
Set xRgEPNo = ActiveSheet.Range("D2:E24")

Set xRgName = xRgName(1)
Set xRgDate = xRgDate(1)
Set xRgSend = xRgSend(1)
Set xRgQual = xRgQual(1)
Set xRgEPNo = xRgEPNo(1)
xRgNameVal = xRgName.Value
xRgSendVal = xRgSend.Value
xRgDateVal = xRgDate.Value
xRgQualVal = xRgQual.Value
xRgEPNoVal = xRgEPNo.Value

Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Dear " & xRgNameVal & ", EP number: " & xRgEPNo & ", " & vbNewLine & vbNewLine & _
"Your " & xRgQualVal & " is expiring on " & xRgDateVal & vbNewLine & _
"Please renew your qualification as soon a possible."
xMailSubject = "Your " & xRgQualVal & " qualification is expiring soon!"

On Error Resume Next
With xOutMail
.To = xRgSendVal
.CC = ""
.BCC = ""
.Subject = xMailSubject
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub

 

[kyameizero]

Thanks, @davesexcel for trying to help me out!

I've changed my code accordingly and tested it out. However, I am still experiencing the same thing.
Does it matter if I have more than one sheet in my workbook? Do I need to declare which sheet I am on the code?
Or is it because I updated my code wrongly?

This is my updated code:
Sub notify1()
Dim c As Range
Dim rng As Range
Dim x As Integer
Dim sh As Worksheet
Set sh = ActiveSheet
With sh
Set rng = .Range("J2:J24")
For Each c In rng.Cells
If c = 1 Then
x = c.Row
Call NewMacro(x)
End If
Next c
End With
End Sub

Private Sub NewMacro(x As Integer)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Dim xRgName As Range
Dim xRgSend As Range
Dim xRgDate As Range
Dim xRgQual As Range
Dim xRgEPNo As Range
Dim xRgNameVal As String
Dim xRgSendVal As String
Dim xRgDateVal As String
Dim xRgQualVal As String
Dim xRgEPNoVal As String
Dim xMailSubject As String
Dim xLastRow As Long
On Error Resume Next

Set xOutApp = CreateObject("Outlook.Application")
Set xRgName = ActiveSheet.Range("B2:B24")
Set xRgDate = ActiveSheet.Range("G2:G24")
Set xRgSend = ActiveSheet.Range("H2:H24")
Set xRgQual = ActiveSheet.Range("E2:E24")
Set xRgEPNo = ActiveSheet.Range("D2:E24")

Set xRgName = xRgName(1)
Set xRgDate = xRgDate(1)
Set xRgSend = xRgSend(1)
Set xRgQual = xRgQual(1)
Set xRgEPNo = xRgEPNo(1)
xRgNameVal = xRgName.Value
xRgSendVal = xRgSend.Value
xRgDateVal = xRgDate.Value
xRgQualVal = xRgQual.Value
xRgEPNoVal = xRgEPNo.Value

Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Dear " & xRgNameVal & ", EP number: " & xRgEPNo & ", " & vbNewLine & vbNewLine & _
"Your " & xRgQualVal & " is expiring on " & xRgDateVal & vbNewLine & _
"Please renew your qualification as soon a possible."
xMailSubject = "Your " & xRgQualVal & " qualification is expiring soon!"

On Error Resume Next
With xOutMail
.To = xRgSendVal
.CC = ""
.BCC = ""
.Subject = xMailSubject
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub

Ignore this reply. Problem solved! Thanks!

 

[kyameizero]

Big thanks to you, @davesexcel, for helping me out! I changed the code according to mine and it works perfectly! Cheers!