VBA电子邮件循环，用于Excel报告

Question

I created a macro that would run a report for a selected indivdual and send that person an email with that package. This report is meant for roughly 20 people, but it has been tedious to run the report for each person and then send it.

I was wondering if there was a way to type names in cells of the people I want to run the report to and have excel loop through each one and send that report to the selected individual and then loop to the next one.

Is this possible, and if so how would I go about creating this macro.

Thank you for your aid

Answer 1

Perhaps you can adjust the code below for your needs. It will send the contents of a textbox on the ActiveSheet to a list of emails in column A. To use it you have to set up your sending email account in Outlook.

Option Explicit
'how to send an email to a list of recipients based on data
'stored in a workbook. The recipient email addresses must
'be in column A, and the body text of the email must be in
'the first text box on the active sheet.

Sub Sample()
   Dim olApp As Object, olMailItm As Object, i As Integer, j As Integer
   Dim r As Range, s As String, numRows As Integer, numCols As Integer
   Dim Dest As Variant, emailAddr As String, txtBox As Shape
   'Create the Outlook application and the empty email.
   Set olApp = CreateObject("Outlook.Application")
   Set olMailItm = olApp.CreateItem(0)
   Set txtBox = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
   200, 100, 400, 100)
   '.TextFrame.TextRange.Text = "Test Box"
   'Using the email, add multiple recipients, using a list of addresses in column A.
   Set r = Range("B1")
   s = "": numCols = 4: numRows = 4
   For j = 1 To numCols
    For i = 1 To numRows
      If i > 1 Then s = s & vbTab
      s = s & r.Offset(j, i)
    Next i
    s = s & vbCr
   Next j
   txtBox.TextFrame2.TextRange.Characters.Text = s
   With olMailItm
       emailAddr = ""
       For i = 1 To WorksheetFunction.CountA(Columns(1))
           If emailAddr = "" Then
               emailAddr = Cells(i, 1).Value
           Else
               emailAddr = emailAddr & ";" & Cells(i, 1).Value
           End If
       Next i

    'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.
       .BCC = emailAddr
       .Subject = "FYI"
       '.body = txtBox.Text
       .body = ActiveSheet.TextBoxes(1).Text
       .Send
   End With

   'Clean up the Outlook application.
   Set olMailItm = Nothing
   Set olApp = Nothing
End Sub