VBA multiple emails and multiple recipients

Rogerisit

Board Regular
Joined
Oct 20, 2016
Messages
70
Office Version
  1. 2019
Hi,

I have the following code (I'm a beginner!) and it all works well except that the emails keep writing over the top of each other.

So the recipient changes and the text in the body duplicates. I want to have multiple emails.

Any help appreciated, thanks.

VBA Code:
Dim xOutlookObj As Object
Dim xEmailObj As Object
 Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)

  For Each MyCell In MyRange
    On Error Resume Next: Sheets(MyCell.Value).Delete: On Error GoTo 0
    Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
    heets(Sheets.Count).Name = Left(MyCell.Value, Len(MyCell.Value) - 18) ' renames the new worksheet
       For i = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
      If ws.Range("D" & i).Value = MyCell.Value And _
         ws.Range("E" & i).Value <> "Miscellaneous" And _
         ws.Range("I" & i).Value = "" Then

        ws.Range("A" & i & ",G" & i & ":H" & i).Copy

         With Sheets(Left(MyCell.Value, Len(MyCell.Value) - 18))
          lr2 = .Range("A" & Rows.Count).End(xlUp).Row + 1
          .Range("A" & lr2).PasteSpecial Paste:=xlPasteValues
             With Sheets(Left(MyCell.Value, Len(MyCell.Value) - 18))
             Range("a1") = MyCell.Value
                 With Sheets(Left(MyCell.Value, Len(MyCell.Value) - 18))
                 Range("A:a").NumberFormat = "dd/mm/yyyy"
                 Range("c:c").NumberFormat = "0.00"
                 Columns("A:A").ColumnWidth = 12#
                 Columns("b:b").ColumnWidth = 40#
                 Columns("c:c").ColumnWidth = 12#
                 Rows("2:500").RowHeight = 20.25
            If WorksheetFunction.CountA(Range("A2")) <> 0 Then
            With xEmailObj
                .Display
                .To = Range("a1").Value
                .Subject = "Miscellaneous"
                .HTMLBody = "<FONT SIZE = 3.5 font face =Calibri> Good afternoon," & "<br/>" & "<br/>" & "The following is miscellaneous." & "<br/>" _
                & "Please, thank you." & .HTMLBody
                If DisplayEmail = False Then
              End If
            End With
         Else
         MsgBox "The active worksheet cannot be blank"
         End If
                 End With
            End With
         End With
         End If
    Next i

 Next MyCell
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
First of all, you have nested loops. I don't know the entire application logic and anything about MyRange but you might want to check that part unless you want to send multiple emails to the same email addresses listed in the A column.

Regarding your question, you need to create individual MailItem object for each email address. It means, you need to move the following code line:
VBA Code:
Set xEmailObj = xOutlookObj.CreateItem(0)

right after the condition in the nested loop. Just like below.

VBA Code:
       For i = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
      If ws.Range("D" & i).Value = MyCell.Value And _
         ws.Range("E" & i).Value <> "Miscellaneous" And _
         ws.Range("I" & i).Value = "" Then
            Set xEmailObj = xOutlookObj.CreateItem(0)

Also, since the .HTMLBody property has not been set before, there is no point to add it to the .HTMLBody - unless you are trying to add the default signature.

Hope this helps.
 
Upvote 0

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top