macro to send emails from slicer

[bb60]

Hi all need a help here.

So i have a an excel dashboard about a team performance, i have a macro to set excel to send a "screen shot" of the performance dashboard for the agent that is selected on the slicer,

but the thing is, i have around 200 agents and doing this one by one is a little by painful.

Is there any way to automate the process ?

Like if the macro was selecting automatically agent by agent on the slicer, and sending the screen shoot of their dashboard of performance?

where is my macro

Sub RangeToOutlook_Single()


'Declare Outlook Variables
Dim oLookApp As Outlook.Application
Dim oLookItm As Outlook.MailItem
Dim oLookIns As Outlook.Inspector

'Declare Word Variables
Dim oWrdDoc As Word.Document
Dim oWrdRng As Word.Range

'Delcare Excel Variables
Dim ExcRng As Range

On Error Resume Next

'Get the Active instance of Outlook if there is one
Set oLookApp = GetObject(, "Outlook.Application")

'If Outlook isn't open then create a new instance of Outlook
If Err.Number = 429 Then

'Clear Error
Err.Clear

'Create a new instance of Outlook
Set oLookApp = New Outlook.Application

End If

'Create a new email
Set oLookItm = oLookApp.CreateItem(olMailItem)
Set Sh = ThisWorkbook.Sheets("Pivot SC")


'Create an array to hold ranges
Set ExcRng = Sheet4.Range("A1:R65")


With oLookItm

'Define some basic info of our email
.SentOnBehalfOfName = ""
.To = Sh.Range("A78").Value
.CC = Sh.Range("A79").Value
.Subject = "Metrics from January"
.Body = " "

'Display the email
.Display

'Get the Active Inspector
Set oLookIns = .GetInspector

'Get the document within the inspector
Set oWrdDoc = oLookIns.WordEditor


ExcRng.Copy

'Define the range, insert a blank line, collapse the selection.
Set oWrdRng = oWrdDoc.Application.ActiveDocument.Content
oWrdRng.Collapse Direction:=wdCollapseEnd

'Add a new paragragp and then a break
Set oWrdRng = oWdEditor.Paragraphs.Add
oWrdRng.InsertBreak

'Paste the object.
oWrdRng.PasteSpecial DataType:=wdPasteMetafilePicture


End With


End Sub