mailmerge VBA

[Mike2502]

Hi All

I have a code which sends an email using active sheet, however I want to send an email with active sheet AND Sheet2 - I'm unsure how to implement this

Regards!

Sub Send_email()
    Dim edress1     As String
    Dim subject     As String
    Dim message     As String
    Dim receiver    As String
    Dim filename    As String
    Dim body        As String
    Dim outlookapp  As Object
    Dim outlookmailitem As Object
    Dim myAttachments As Object
    Dim path        As String
    Dim lastrow     As Integer
    Dim attachment  As String
    Dim x           As Integer
    
    Dim MyDate
    Dim Month
    Dim StrName     As String
    
    MyDate = Format(Date, "yyyymmdd")
    Month = Format(Date, "mmmm")
    
    x = 2
    Do Until ActiveCell(0, 5).Select
        Do Until ActiveCell.Value = ""
            
            Dim Answer As VbMsgBoxResult
            
            Answer = MsgBox("Are you sure you wish To send the email(s)?", vbYesNo, "Send Email")
            
            If Answer = vbYes Then
                
                Dim ws As Worksheet
                Set ws = ActiveSheet
                Do While ActiveSheet.Cells(x, 1) <> ""
                    
                    Set outlookapp = CreateObject("Outlook.Application")
                    Set outlookmailitem = outlookapp.createitem(0)
                    Set myAttachments = outlookmailitem.Attachments
                    path = "C:\Users\file" & Month & "\"
                    
                    receiver = ActiveSheet.Cells(x, 14)
                    subject = ActiveSheet.Cells(x, 15)
                    filename = ActiveSheet.Cells(x, 13)
                    body = ActiveSheet.Cells(1, 16).Value
                    StrName = MyDate & " - " & filename
                    '.SentOnBehalfOfName = ""
                    attachment = path + StrName + ".pdf"
                    
                    outlookmailitem.To = receiver
                    
                    outlookmailitem.cc = ""
                    outlookmailitem.bcc = ""
                    outlookmailitem.subject = subject
                    outlookmailitem.body = body
                    myAttachments.Add (attachment)
                    outlookmailitem.send
                    lastrow = lastrow + 1
                    edress1 = ""
                    
                    x = x + 1
                Loop
                
                Set outlookapp = Nothing
                Set outlookmailitem = Nothing
                
            End If
        End Sub

 

[Mike2502]

Bump

 

[Mike2502]

Bump

Keep getting Do without Loop error!