How to forward email based on criteria?

Question

How can I send mails automatically based on criteria?

I want to open the mail based on the subject provided in column A, add default content and forward this mail to the email address provided in Column B.

I know how to open an Outlook mail based on the subject.

Sub Test()
    Dim olApp As Outlook.Application
    Dim olNs As Namespace
    Dim Fldr As MAPIFolder
    Dim olMail As Variant
    Dim i As Integer

    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
    i = 1

    For Each olMail In Fldr.Items
        If InStr(olMail.Subject, "") <> 0 Then
            olMail.Display
            i = i + 1
        End If
    Next olMail
End Sub

Subject (column A)      Send to (Column B) 
SP12345667              aaa@gmail.com
SP12345668              bbb@gmail.com
SP12345669              xxx@abc.com
SP12345670              yyy@abc.com
SP12345671              mmm@abc.com
SP12345672              nnn@abc.com
SP12345673              yyy@abc.com

Answer 1

Here is an Example on how to loop...

Option Explicit
Public Sub Example()
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim Inbox As Outlook.MAPIFolder
    Dim Item As MailItem
    Dim MsgFwd As MailItem
    Dim Items As Outlook.Items
    Dim Recip As Recipient
    Dim Email As String
    Dim ItemSubject As String
    Dim lngCount As Long
    Dim i As Long

    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items

    i = 2 '  i = Row 2

    With Worksheets("Sheet1") ' Sheet Name
        Do Until IsEmpty(.Cells(i, 1))

        ItemSubject = .Cells(i, 1).Value '(i, 1) = (Row 2,Column 1) 
        Email = .Cells(i, 2).Value '(i, 2) = (Row 2,Column 2) 

            '// Loop through Inbox Items backwards
            For lngCount = Items.Count To 1 Step -1
                Set Item = Items.Item(lngCount)

                If Item.Subject = ItemSubject Then ' if Subject found then
                    Set MsgFwd = Item.Forward
                    Set Recip = MsgFwd.Recipients.Add(Email) ' add Recipient
                        Recip.Type = olTo

                        MsgFwd.Display

                End If
            Next ' exit loop

            i = i + 1 '  = Row 2 + 1 = Row 3
        Loop
    End With

    Set olApp = Nothing
    Set olNs = Nothing
    Set Inbox = Nothing
    Set Item = Nothing
    Set MsgFwd = Nothing
    Set Items = Nothing
End Sub