VBA macro to email

kyameizero

New Member
Joined
Jan 2, 2020
Messages
19
Office Version
  1. 365
Platform
  1. Windows
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
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

davesexcel

Well-known Member
Joined
Feb 26, 2006
Messages
1,089
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.

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

New Member
Joined
Jan 2, 2020
Messages
19
Office Version
  1. 365
Platform
  1. Windows
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

New Member
Joined
Jan 2, 2020
Messages
19
Office Version
  1. 365
Platform
  1. Windows
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

New Member
Joined
Jan 2, 2020
Messages
19
Office Version
  1. 365
Platform
  1. Windows
Big thanks to you, @davesexcel, for helping me out! I changed the code according to mine and it works perfectly! Cheers!
 

Forum statistics

Threads
1,136,968
Messages
5,678,870
Members
419,787
Latest member
juanam

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