Sending outlook emails using excel vba

Question

I'm having a problem with my code and am not sure how to fix this.

I have a code here wherein using Excel, I can automatically reply Outlook emails which I selected/highlighted inside the outlook app. And there are different email messages and subject lines based on the order which i selected the email messages.

The problem is there are emails that were not working and replying to the wrong email, it should only reply those which i highlighted in outlook email. For example when i selected 3 emails there are instances that the two replied the correct but the other one replied the email which I did not highlighted. Here is my Excel vba code below

Sub SendEmail()
    Dim OutlookApp As Object
    Dim OutlookMail As Object  
    i = 1

    Do While Not IsEmpty(Cells(i + 1, 4))  
        Set OutlookApp = CreateObject("Outlook.Application")
        Set OutlookMail = OutlookApp.ActiveExplorer.Selection.Item(i)   
        Dim OutlookConversation As Object
        Set OutlookConversation = OutlookMail.GetConversation  
        Dim OutlookTable As Object
        Set OutlookTable = OutlookConversation.GetTable 
        Dim OutlookAr As Variant
        OutlookAr = OutlookTable.GetArray(OutlookTable.GetRowCount)
        Dim OutlookReplyToThisMail As Object
        Set OutlookReplyToThisMail = OutlookMail.Session.GetItemFromID(OutlookAr(UBound(OutlookAr), 0))
        With OutlookReplyToThisMail.ReplyAll
            .Subject = Sheet1.Cells(1 + i, 15) & "_" & .Subject
            .HTMLBody = "<p style='font-family:calibri;font-size:13'>" & _
            Sheet1.Cells(34, 2 + i) & "<br>" & "<br>" & _
            Sheet1.Cells(35, 2 + i) & "<br>" & "<br>" & _
            Sheet1.Cells(36, 2 + i) & Signature & .HTMLBody
            .Display     
        End With 

        i = i + 1
    Loop
End Sub

Answer 1

First of all, creating a new Outlook Application instance in the loop is not actually a good idea:

Do While Not IsEmpty(Cells(i + 1, 4))  
        Set OutlookApp = CreateObject("Outlook.Application")

Instead, consider moving the creation line above before the loop:

Set OutlookApp = CreateObject("Outlook.Application")

Do While Not IsEmpty(Cells(i + 1, 4))          

In the code you are iterating over Excel cells and get corresponding selected items in Outlook.

it should only reply those which i highlighted in outlook email.

If you need to iterate over all selected items in Outlook you need to not rely on the Excel's data and have got a separate loop based on the number of selected items. For example:

 Dim myOlExp As Outlook.Explorer  
 Dim myOlSel As Outlook.Selection 
 Set myOlExp = OutlookApplication.ActiveExplorer  
 Set myOlSel = myOlExp.Selection  
 For x = 1 To myOlSel.Count  
   If myOlSel.Item(x).Class = OlObjectClass.olMail Then  
     ' For mail item, use the SenderName property. 
     Set oMail = myOlSel.Item(x)  
     Debug.Print oMail.SenderName 
   End If
 Next