问将电子邮件列表复制到Outlook

EN

Sub MeetingMacro()
'MsgBox Hour(Now)
If Weekday(Now, vbMonday) >= 6 And Hour(Now) > 12 Then
Exit Sub
End If

Application.ScreenUpdating = False

Dim pt As PivotTable
Set pt = ThisWorkbook.Sheets("Sheet2").PivotTables("PivotTable")
pt.RefreshTable
Application.CalculateUntilAsyncQueriesDone
Call saveAsXlsx1
Application.CalculateUntilAsyncQueriesDone
Call savefile
Application.CalculateUntilAsyncQueriesDone
Call Send_Range
'Call Send_Range


End Sub

Sub Send_Range()

   Dim TBL As ListObject
     ThisWorkbook.Activate

   ThisWorkbook.EnvelopeVisible = False
   ThisWorkbook.Sheets("Sheet2").Range("A1:B30").Select
    ThisWorkbook.Activate
   With ActiveSheet.MailEnvelope

            SDest = ""
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3))
           If SDest = "" Then
               SDest = Cells(iCounter, 3).Value
               SDest.Value.Select
           Else
               SDest = SDest & ";" & Cells(iCounter, 3).Value
           End If
       Next iCounter

      .Item.To = SDest
      .Item.CC = "someone@example.com"
      .Item.Subject = "[URGENT] Meeting has been cancelled. "
      .Item.HTMLBody = "Hello," & vbCrLf & "Meeting has been cancelled. Fresh invite will be sent soon.” & vbCrLf & "Regards"
      .Item.Attachments.Add "C:\Attachment.xlsx" 'ActiveWorkbook.FullName
      .Item.Send
   End With

   'MsgBox (TimeOfDay)
End Sub


'MsgBox (TimeOfDay)
Sub savefile()
 Application.ScreenUpdating = False
     ThisWorkbook.Activate
     Application.ScreenUpdating = True
ThisWorkbook.Save
End Sub
Sub saveAsXlsx1()
ThisWorkbook.Worksheets(Array("Sheet2")).Copy
Application.DisplayAlerts = False
 ActiveSheet.Shapes.Range("FetchData").Delete
ActiveWorkbook.SaveAs Filename:="C:\Attachment.xlsx"
ActiveWorkbook.Close
End Sub

Sub Meeting4()
ThisWorkbook.Application.DisplayAlerts = False
ActiveWorkbook.Save
ThisWorkbook.Close
End Sub