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.
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