Jun 27 2022 03:17 PM - edited Jun 30 2022 12:44 PM
Dears,
Could you please help me regarding the attached sheet as i want to send a recurrent email to every employee with his salary through the excel.
N.B: Sheet password 123
Thanks
Jun 28 2022 04:02 AM
Here is a macro. Don't forget to save the workbook as a macro-enabled workbook (*.xlsm).
Sub SendMessages()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim r As Long
Dim m As Long
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Master Sheet ")
Set ws2 = wb1.Worksheets("Sheet1")
m = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
For r = 9 To m
If ws1.Range("V" & r).Value <> "" Then
ws2.Range("A4").Value = ws1.Range("B" & r).Value
ws2.Copy
Set wb2 = ActiveWorkbook
Set ws3 = wb2.Worksheets(1)
ws3.Unprotect Password:="123"
With ws3.UsedRange
.Value = .Value
End With
ws3.Protect Password:="123"
wb2.SendMail Recipients:=ws1.Range("V" & r).Value, Subject:="Salary Specification"
wb2.Close SaveChanges:=False
End If
Next r
Application.ScreenUpdating = True
End Sub
Jun 28 2022 08:26 AM
Thanks you Mr. Hans
is there any way to send the emails without appear the attached screen as i have to click allow in every line in the list.
thanks in advance
Jun 28 2022 09:52 AM
The following version works best if Outlook is already running when you start the macro,
Sub SendMessages()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim r As Long
Dim m As Long
Dim objOL As Object
Dim objMsg As Object
Dim f As Boolean
Dim sFile As String
Application.ScreenUpdating = False
On Error Resume Next
Set objOL = GetObject(Class:="Outlook.Application")
If objOL Is Nothing Then
f = True
Set objOL = CreateObject(Class:="Outlook.Application")
End If
On Error GoTo ErrHandler
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Master Sheet ")
Set ws2 = wb1.Worksheets("Sheet1")
m = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
For r = 9 To m
If ws1.Range("V" & r).Value <> "" Then
ws2.Range("A4").Value = ws1.Range("B" & r).Value
ws2.Copy
Set wb2 = ActiveWorkbook
Set ws3 = wb2.Worksheets(1)
ws3.Unprotect Password:="123"
With ws3.UsedRange
.Value = .Value
End With
ws3.Protect Password:="123"
sFile = ws1.Range("B" & r).Value & ".xlsx"
wb2.SaveAs Filename:=sFile
wb2.Close SaveChanges:=False
Set objMsg = objOL.CreateItem(0)
objMsg.Subject = "Salary Specification"
objMsg.Body = "Please find the salary specification attached to this message"
objMsg.To = ws1.Range("V" & r).Value
objMsg.Attachments.Add sFile
objMsg.Send
Kill sFile
End If
Next r
ExitHandler:
On Error Resume Next
If f Then
objOL.Quit
End If
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
Application.ScreenUpdating = True
End Sub
Jun 28 2022 10:04 AM
Jun 28 2022 10:37 AM
SolutionThe sample workbook has column V for email address. The code checks that this column is not empty:
If ws1.Range("V" & r).Value <> "" Then
So it should not create an email message for rows that have no email address.
Jun 29 2022 06:34 AM - edited Jun 30 2022 12:45 PM
Dear Mr. Hans,
Could you please help me for the attached issue as i did some modification in the master data sheet (adding culumns and rearrange some of them) but it shows error when i tried to run the macro.
and sorry for send my issue in a private message.
Thanks in advance
Jun 29 2022 07:19 AM
Jun 29 2022 07:38 AM
You modified the code correctly.
As I wrote in my PM, I added a folder path for the attachments; that appears to prevent the error.
Jun 28 2022 10:37 AM
SolutionThe sample workbook has column V for email address. The code checks that this column is not empty:
If ws1.Range("V" & r).Value <> "" Then
So it should not create an email message for rows that have no email address.