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

Glennduck

New Member
Joined
Dec 11, 2020
Messages
4
Office Version
  1. 365
  2. 2011
Platform
  1. Windows
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
 

Attachments

  • PTO Tracker 2.JPG
    PTO Tracker 2.JPG
    76.6 KB · Views: 6

Some videos you may like

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

davesexcel

Well-known Member
Joined
Feb 26, 2006
Messages
1,089
Try this out.

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

Glennduck

New Member
Joined
Dec 11, 2020
Messages
4
Office Version
  1. 365
  2. 2011
Platform
  1. Windows
Thanks for the quick reply Dave! I'll give that a try and see how it works.
 

Glennduck

New Member
Joined
Dec 11, 2020
Messages
4
Office Version
  1. 365
  2. 2011
Platform
  1. Windows
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
55,412
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

@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

New Member
Joined
Dec 11, 2020
Messages
4
Office Version
  1. 365
  2. 2011
Platform
  1. Windows
Try this out.

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

Well-known Member
Joined
Feb 26, 2006
Messages
1,089
If you wanted a second range to copy/paste
VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,318
Messages
5,623,976
Members
416,003
Latest member
indyman

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