Skicka unika arbetsblad med en rapport till flera mottagare

Sända flera e-post med en sammanfattningsrapport och unika arbetsblad till flera mottagare

I detta tips demonstreras hur vi kan skicka separata e-post till enskilda mottagare, innehållande en gemensam rapport men med skilda underrapporter (arbetsblad) i en och samma procedur.

Här använder vi oss av "early binding" varför vi måste sätta en referens till MS Outlook Object Library x.x via Verktyg | Referenser... i VB-editorn.

Option Explicit

Sub Skicka_Arbetsblad_WordRapport_Flera_Mottagare()

   '© 2003 Alla rättigheter XL-Dennis

   Dim wbBok As Workbook

   Dim wsBlad As Worksheet

   Dim rnMottagare As Range, rnArbetsblad As Range

   Dim stNamn As String

   Dim i As Long

   Dim olApp As Outlook.Application

   Dim olNewMail As Outlook.MailItem

   Set olApp = New Outlook.Application

   Set wbBok = ThisWorkbook

   Set wsBlad = wbBok.Worksheets("Blad1")

   With wsBlad

      'Lista över e-postmottagare, såsom "xxxx@xldennis.com"

      Set rnMottagare = .Range("rnMottagare")

      'Lista över arbetsbladens namn.

      Set rnArbetsblad = .Range("rnArbetsblad")

   End With

   Application.ScreenUpdating = False

   'Här skapas varje e-post och där Word-filen "Rapport.doc" bifogas

   'men där unika arbetsblad skickas till respektive mottagare.

   For i = 1 To rnMottagare.Count

      Set olNewMail = CreateItem(olMailItem)

      With olNewMail

         .Recipients.Add rnMottagare(i, 1).Value

         .Subject = "Ärende: Veckorapport"

         .Body = "Enligt överenskommelse //Dennis"

         With .Attachments

            .Add ThisWorkbook.Path & "\" & "Rapport.doc"

            .Item(1).DisplayName = "Sammanfattning"

            stNamn = rnArbetsblad(i, 1).Value

            'Skapar en ny arbetsbok.

            wbBok.Worksheets(stNamn).Copy

            'Omvandlar formler till konstanta värden.

            With ActiveSheet.UsedRange

               .Copy

               .PasteSpecial Paste:=xlValues

            End With

            Application.CutCopyMode = False

            'Sparar den skapade arbetsboken och stänger den.

            With ActiveWorkbook

               .SaveAs Filename:=stNamn & ".xls"

               .Close

            End With

            .Add ThisWorkbook.Path & "\" & stNamn & ".xls"

            .Item(2).DisplayName = "Månadsresultat"

         End With

         .Save

         .Send

      End With

   Next i

   Set olNewMail = Nothing

   Set olApp = Nothing

   'Ta bort de skapade arbetsböckerna.

   For i = 1 To rnMottagare.Count

      Kill ThisWorkbook.Path & "\" & rnArbetsblad(i, 1).Value & ".xls"

   Next i

   Application.ScreenUpdating = True

End Sub