Forum Discussion

hussein_elsayed's avatar
hussein_elsayed
Brass Contributor
Jun 27, 2022
Solved

Excel help

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

excel
  • HansVogelaar's avatar
    HansVogelaar
    Jun 28, 2022

    hussein_elsayed 

    The 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.

11 Replies

  • HansVogelaar's avatar
    HansVogelaar
    MVP
    Jun 28, 2022

    hussein_elsayed 

    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
    • hussein_elsayed's avatar
      hussein_elsayed
      Brass Contributor
      Jun 28, 2022

      HansVogelaar 

      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

      • HansVogelaar's avatar
        HansVogelaar
        MVP
        Jun 28, 2022

        hussein_elsayed 

        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

Resources