VBA multiple emails and multiple recipients

[Rogerisit]

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.

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

 

[smozgur]

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:

Set xEmailObj = xOutlookObj.CreateItem(0)

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

       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.