im trying to create a VBA Macro to email specific staff the daily task allocated to them-CodePudding

currently, I have a standard macro that emails a basic email template that sends to all staff, but I want to edit the macro, so it includes the tasks assigned in the email assigned to the Staff.

currently "A1" will have the staff name and then "B1-B5" will have the tasks" then there's a blank row followed by the next "staff" member. (so A7) would be the next staff name. (as the number of tasks that could be allocated to each staff member is random and could change any day, the above is just an example to give you a rough idea of how the spreadsheet works) I have a sheet with the staff names and a list of the email address next to them.

I'm still very new to coding and while looking online, I've managed to copy the below and get this working on my spreadsheet.

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
'Updated by Extendoffice 20181102
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xName As String
    On Error Resume Next
    Set xOutApp = CreateObject("Outlook.Application")
    Set xMailItem = xOutApp.CreateItem(0)
    xName = ActiveWorkbook.FullName
    With xMailItem
        .To = "[email protected]"
        .CC = ""
        .Subject = "TEST"
        .Body = "Hi," & Chr(13) & Chr(13) & "File is now updated."
        .Attachments.Add xName
        .Display
       '.send
    End With
    Set xMailItem = Nothing
    Set xOutApp = Nothing
End Sub

CodePudding user response：

Could you put the staff member's email address in the sheet, for example in C1 opposite the manager's name? (or even instead of the manager's name)

If it's in C1, your code should look like this.

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    Dim xOutApp As Object, xMailItem As Object
    Dim xName As String, lManager as Long, lTask as Long, shtTasks as Worksheet
    Set xOutApp = CreateObject("Outlook.Application")
    Set shtTasks = ActiveSheet
    xName = ActiveWorkbook.FullName

   'Loop through Managers
    lManager = 1
    Do Until lManager >= shtTasks.UsedRange.Rows.Count
        If shtTasks.Range("A" & lManager) <> "" Then 'to prevent blank emails being created on lines with no manager
        Set xMailItem = xOutApp.CreateItem(0)
        With xMailItem
            .To = shtTasks.Range("C" & lManager) 'This is the cell with the email address in it
            .Subject = "TEST"
            .Body = "Hi," & chr(13) & chr(13) & "File is now updated." & chr(13) & "Your tasks are: "

            'Loop through Tasks:
            lTask = lManager
            Do Until shtTasks.Range("B" & lTask) = ""
                .Body = .Body & " " & shtTasks.Range("B" & lTask) & ", "
                lTask = lTask   1
            Loop
            .Body = Left(.Body, Len(.Body)-2) & "." 'replace the last comma with a full stop

            .Attachments.Add xName
            .Display
            '.Send
            Set xMailItem = Nothing
            lManager = lTask   1 'Move to next manager
        End With
        End If
    Loop
    Set xOutApp = Nothing
End Sub