VBA - email different range of excel sheet to different email addresses

[Glennduck]

I need some help with the macro below that I want to use to send each employee their PTO report (range of cells on sheet) - see attached image. I have the macro below which enables me to send the first report - cells B12:R15 to the email name in cell D12 but now want to modify it to send their individual reports to each of them. I played around with it in the second script shown below but am stuck on how to apply this to a variable range of reports to email to each employee. The number of reports on a sheet varies over time...to add to the fun
Need some of assistance from you all with expert VB skills ...I'm a newbie at VB macros.
Thanks!


Macro for first report
Sub Emailreport()

Range([INDIRECT("A12")]).Copy
Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = Range("D12").Value
.CC = Range("D11").Value
.Subject = "PTO Report"
.Display
End With
OutMail.Subject.Activate
Application.SendKeys "^v"
On Error GoTo 0
Set OutMail = Nothing

End Sub


Macro to send to all
Sub EmailreportDynamic()
Dim r As Range
Set r = ActiveCell
With r
Range([INDIRECT("r")]).Copy
End With
Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = Range("D12").Value
.CC = Range("D11").Value
.Subject = "PTO Report"
.Display
End With
OutMail.Subject.Activate
Application.SendKeys "^v"
On Error GoTo 0
Set OutMail = Nothing

End Sub

 

[davesexcel]

Try this out.

Sub Emailreport()
    Dim sh As Worksheet
    Dim rng As Range, c As Range
    Dim cc As String
    Dim doc As Object
    
    Set sh = ActiveSheet
    With sh
        cc = .Range("D11").Value
    
        Set rng = .Range("B10:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
        'start loop
        For Each c In rng.Cells
            If c = "Last Name" Then

                With CreateObject("Outlook.Application").CreateItem(0)
                    .Display
                    Set doc = .GetInspector.WordEditor
                    c.Resize(4, 17).Copy
                    doc.Range(0, 0).Paste
                    .To = c.Offset(, 2)
                    .cc = cc
                    .Subject = "PTO Report"
                End With
            End If
        Next c
    
        'end loop
        Application.CutCopyMode = False
    End With
    
End Sub

 

[Glennduck]

Thanks for the quick reply Dave! I'll give that a try and see how it works.

 

[Glennduck]

Thanks Dave, Jedi Excel Master! That's amazing. Worked great. I should of asked sooner. I definitely want to learn more about VBA - a whole new level of capabilities that I've just scratched the surface of. Any suggestions on good resources where I can learn more?

 

[Fluff]

@Glennduck You are meant to mark the post that helped you the most as the solution, not your own post saying it worked.
I have changed it for you this time.

 

[Glennduck]

Try this out.

Sub Emailreport()
    Dim sh As Worksheet
    Dim rng As Range, c As Range
    Dim cc As String
    Dim doc As Object
   
    Set sh = ActiveSheet
    With sh
        cc = .Range("D11").Value
   
        Set rng = .Range("B10:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
        'start loop
        For Each c In rng.Cells
            If c = "Last Name" Then

                With CreateObject("Outlook.Application").CreateItem(0)
                    .Display
                    Set doc = .GetInspector.WordEditor
                    c.Resize(4, 17).Copy
                    doc.Range(0, 0).Paste
                    .To = c.Offset(, 2)
                    .cc = cc
                    .Subject = "PTO Report"
                End With
            End If
        Next c
   
        'end loop
        Application.CutCopyMode = False
    End With
   
End Sub

Hi Dave, I'd like to add a disclaimer statement below each PTO report in the body of the email messages. How do I add that? It would be the same disclaimer message on all the emails. Thanks!

 

[davesexcel]

If you wanted a second range to copy/paste

Sub Emailreport()
    Dim sh As Worksheet
    Dim rng As Range, c As Range
    Dim cc As String
    Dim doc As Object
    Dim Stmnt As Range
   
    Set sh = ActiveSheet
    With sh
        cc = .Range("D11").Value
        Stmnt = .Range("P1:Q3") ' range where the statment is(disclaimer)
   
        Set rng = .Range("B10:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
        'start loop
        For Each c In rng.Cells
            If c = "Last Name" Then

                With CreateObject("Outlook.Application").CreateItem(0)
                    .Display
                    Set doc = .GetInspector.WordEditor
                    c.Resize(4, 17).Copy
                    doc.Range(0, 0).Paste
                    
                    x = doc.Range.End - 1
                    Stmnt.Copy
                    doc.Range(x).Paste
                    
                    .To = c.Offset(, 2)
                    .cc = cc
                    .Subject = "PTO Report"
                End With
            End If
        Next c
   
        'end loop
        Application.CutCopyMode = False
    End With
   
End Sub