Kirim Email sekaligus ke banyak penerima

            Saya  baru tahu  ternyata  ada rekan di supply chain yang harus mengirim email ke banyak penerima setiap  hari, hal ini  di lakukan untuk mengirim PO ke supplier.
PO yang  harus  di kirim berbentuk attachment  PDF file dan harus di kirim  ke banyak suplier setiap ada PO  baru.Jumlah supplier  yang harus di kirimi email mencapai  200 supplier, dan di lakukan satu persatu tergantung PO dan  supplier nya.Terlintas  di pikiran saya begitu manual dan capek nya mereka harus buat email dan meletakan attachment nya,bisa saja  PO  yang di kirim salah alamat.
dan tentunya  waktu yang dibutuhkan sangat  lama, jika kirim satu email  butuh 2 menit, maka untuk menuntaskan 200 email akan butuh 400 menit = 6 JAM  lebih ,  woooowwww....
Dan karena satu orang  yang merasa proses ini  bisa di otomisasi,dan dia juga minta dibuatkan macro nya, maka  dengan senang hati saya buatkan macro nya, gak tega mereka melakukan ini....sementara saya tahu cara nya yg lebih singkat dan akurat.

maka setelah di buatkan macro nya, untuk mengirim email ke lebih dari  200 alamat berbeda hanya  butuh  waktu  30  detik.

macro nya seperti dibawah:

Option Explicit

Const EMBED_ATTACHMENT As Long = 1454

Const stPath As String = "E:\attachment"

Sub Send_EMAIL_w_Attach()

  Dim stFileName As String
  Dim stFileName1 As String
  Dim vaRecipients As Variant
  Dim stSubject As String
  Dim noSession As Object
  Dim noDatabase As Object
  Dim noDocument As Object
  Dim noEmbedObject As Object
  Dim noAttachment As Object
  Dim stAttachment As String
  Dim stAttachment1 As String
  Dim vaMsg As Variant
  Dim vaCopyTo As Variant


'  'Copy the active sheet to a new temporarily workbook.
'  With ActiveSheet
'    .Copy
'    stFileName = .Range("E2").Value
'  End With
'
'  stFileName = Range("E2").Value
'  stFileName1 = Range("F2").Value
'  stAttachment = stPath & "\" & stFileName
'  stAttachment1 = stPath & "\" & stFileName1

  'Save and close the temporarily workbook.
'  With ActiveWorkbook
'    .SaveAs stAttachment
'    .Close
'  End With

Range("A2").Select
Dim r, k1, k2, k3, k4, k5, k6, I, b As Integer
r = 2
k1 = 1
k2 = 2
k3 = 3
k4 = 4
k5 = 5
k6 = 6
 b = Range(Range("A1"), Range("A1").End(xlDown)).Rows.Count
 'On Error Resume Next
 For r = 1 To b
   ' If ActiveCell.Value <> "" Then
   
   
  stSubject = Cells(r, k1).Value 'email title
  vaMsg = Cells(r, k2).Value ' email body
  vaRecipients = Cells(r, k3).Value ' email adress to
  vaCopyTo = Cells(r, k4).Value ' email adress cc
 
  '======attachment=======================
   stFileName = Cells(r, k5).Value   'attachment 1
  stFileName1 = Cells(r, k6).Value   'attachment 2
  stAttachment = stPath & "\" & stFileName
  stAttachment1 = stPath & "\" & stFileName1
  '========================================
 
  'Instantiate the Lotus Notes COM's Objects.
  Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")

  'If Lotus Notes is not open then open the mail-part of it.
  If noDatabase.IsOpen = False Then noDatabase.OPENMAIL

  'Create the e-mail and the attachment.
  Set noDocument = noDatabase.CreateDocument
  Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
  Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
 
  Set noAttachment = noDocument.CreateRichTextItem("stAttachment1")
  Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment1)
 

  'Add values to the created e-mail main properties.
  With noDocument
    .Form = "Memo"
    .SendTo = vaRecipients
    .CopyTo = vaCopyTo
    .Subject = stSubject
    .Body = vaMsg
    .SaveMessageOnSend = True
    .PostedDate = Now()
    .Send 0, vaRecipients
  End With

  'Release objects from memory.
  Set noEmbedObject = Nothing
  Set noAttachment = Nothing
  Set noDocument = Nothing
  Set noDatabase = Nothing
  Set noSession = Nothing

    'r = r + 1
    ActiveCell.Offset(1, 0).Activate
   ' End If
   
   Next r

End Sub