Choose different email body based on cell value

Question

There are 3 body contents to be picked based on the value in D column.

1) if "D" column value is "High" then bodycontent1 should be selected

2) if "D" column value is "Medium" then bodycontent2 should be selected

3) if "D" column value is "Low" then bodycontent3 should be selected

The below code just picks the bodycontent1 for any criteria.

Code:

Option Explicit
Public Sub Example()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Variant
Dim MsgFwd As MailItem
Dim Items As Outlook.Items
Dim Email As String
Dim Email1 As String
Dim ItemSubject As String
Dim lngCount As Long
Dim i As Long
Dim RecipTo As Recipient
Dim RecipCC As Recipient
Dim RecipBCC As Recipient
Dim onbehalf As Variant
Dim EmailBody As String
Dim BodyName As String
Dim Bodycontent1 As String
Dim Bodycontent2 As String
Dim Bodycontent3 As String
Dim Criteria1 As String


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, 16).Value '(i, 2) = (Row 2,Column 2)
Email1 = .Cells(i, 2).Value
Criteria1 = .Cells(i, 4).Value

Bodycontent1 = "Hello this is for testing purpose1" & "<BR>" & _
"Regards," & "<BR>" & _
"Kelvin"

Bodycontent2 = "Hello this is for testing purpose2" & "<BR>" & _
"Regards," & "<BR>" & _
"Kelvin"

Bodycontent3 = "Hello this is for testing purpose3" & "<BR>" & _
"Regards," & "<BR>" & _
"Kelvin"


 '// 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 RecipTo = MsgFwd.Recipients.Add(Email1) 
Set RecipTo = MsgFwd.Recipients.Add("secnww@hp.com")
Set RecipBCC = MsgFwd.Recipients.Add(Email) 
MsgFwd.SentOnBehalfOfName = "doc@hp.com"
BodyName = .Cells(i, 3).Value

RecipTo.Type = olTo
RecipBCC.Type = olBCC

Debug.Print Item.Body

If Criteria1 = "high" Then

MsgFwd.HTMLBody = Bodycontent1 & Item.HTMLBody

ElseIf Criteria1 = "medium" Then

MsgFwd.HTMLBody = Bodycontent2 & Item.HTMLBody

Else 'If Criteria1 = "Low" Then

MsgFwd.HTMLBody = Bodycontent3 & Item.HTMLBody

MsgFwd.Display

End If
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

MsgBox "Mail sent"

End Sub

Answer 1

1. You should use Select Case rather than If/ElseIf
2. See the part about LastRow which is clear than Loop+ i=i+1
3. I've added an Exit For (commented), in case you want to gain time, and only forward the 1st message with the subject you're looking for!

Final code :

Option Explicit
Public Sub Example()
Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Variant
Dim MsgFwd As MailItem
Dim wS As Worksheet
Dim Items As Outlook.Items
Dim Email As String
Dim Email1 As String
Dim ItemSubject As String
Dim lngCount As Long
Dim LastRow As Long
Dim i As Long
Dim BodyName As String
Dim Bodycontent1 As String
Dim Bodycontent2 As String
Dim Bodycontent3 As String
Dim Criteria1 As String


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


Bodycontent1 = "Hello this is for testing purpose1" & "<BR>" & _
"Regards," & "<BR>" & _
"Kelvin"

Bodycontent2 = "Hello this is for testing purpose2" & "<BR>" & _
"Regards," & "<BR>" & _
"Kelvin"

Bodycontent3 = "Hello this is for testing purpose3" & "<BR>" & _
"Regards," & "<BR>" & _
"Kelvin"



Set wS = thisworkbook.Worksheets("Sheet1") ' Sheet Name
With wS
    LastRow = .Range("A" & .rows.Count).End(xlup).Row
    For i = 2 To LastRow
        ItemSubject = .Cells(i, 1).value
        Email = .Cells(i, 16).value
        Email1 = .Cells(i, 2).value
        Criteria1 = .Cells(i, 4).value
        BodyName = .Cells(i, 3).value

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

            If Item.Subject <> ItemSubject Then
            Else
                'If Subject found then
                Set MsgFwd = Item.Forward
                With MsgFwd
                    .To = Email1 & " ; secnww@hp.com"
                    .BCC = Email
                    .SentOnBehalfOfName = "doc@hp.com"

                    Select Case LCase(Criteria1)
                        Case Is = "high"
                            .HTMLBody = Bodycontent1 & Item.HTMLBody
                        Case Is = "medium"
                            .HTMLBody = Bodycontent2 & Item.HTMLBody
                        Case Is = "low"
                            .HTMLBody = Bodycontent3 & Item.HTMLBody
                        Case Else
                            MsgBox "Criteria : " & Criteria1 & " not recognised!", _
                                    vbCritical + vbOKOnly, "Case not handled"
                    End Select

                    .Display
                    'Exit For
                End With 'MsgFwd
            End If
        Next lngCount
    Next i
End With 'wS

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

MsgBox "Mail sent"

End Sub