Outlook to excel VBA Stops searching message body after first match?

[Legacy 296444]

I wrote a code to pull data from outlook to excel, And its 80% working It does pull info but not from the whole email.
I receive emails in the same format with pricing and other info on them. These are for purchase orders what have more than 1 line usually. They are in this format:


Item Number : 00001
Vendor Sales Order Number :
Vendor Material Number :
SAP Material Number :
Vendor Description :
SAP Description :
Vendor Quantity : 30.000 EA
SAP Quantity : 30.000 EA
Quantity UOM : EA
Vendor Delivery Date : 20.09.2014
SAP Delivery Date : 20.09.2014
Action Request :
Following details does not match for PO line item 00001
Vendor Price : USD 0.00 for 1 EA
SAP Price : USD 0.01 for 1 EA
Item Number : 00002
Vendor Sales Order Number :
Vendor Material Number :
SAP Material Number :
Vendor Description :
SAP Description :
Vendor Quantity : 70.000 EA
SAP Quantity : 70.000 EA
Quantity UOM : EA
Vendor Price : USD 3.90 for 1 EA
SAP Price : USD 3.90 for 1 EA
Vendor Delivery Date : 20.09.2014
SAP Delivery Date : 20.09.2014




As you can see from the code i am pulling multiple things from these emails that have the same beginning string. After it pulls line 1, the code moves to the next email without searching the entire body of the email for further matches. Each order can have multiple line items each laid out in this format. How can i fix this? Stuck

(i have tried a few code changes. At one point it was pulling all the data but sticking it all in totally different rows. Figured id reach out for some help.)

[COLOR=#000000][FONT=Courier New]Option ExplicitSub CopyToExcel()Dim xlApp As ObjectDim xlWB As ObjectDim xlSheet As ObjectDim olItem As Outlook.MailItemDim vText As VariantDim sText As StringDim vItem As VariantDim i As LongDim rCount As LongDim bXStarted As BooleanConst strPath As String = "Filepath here" 'the path of the workbookIf Application.ActiveExplorer.Selection.Count = 0 Then    MsgBox "No Items selected!", vbCritical, "Error"    Exit SubEnd IfOn Error Resume NextSet xlApp = GetObject(, "Excel.Application")If Err <> 0 Then    Application.StatusBar = "Please wait while Excel source is opened ... "    Set xlApp = CreateObject("Excel.Application")    bXStarted = TrueEnd IfOn Error GoTo 0'Open the workbook to input the dataSet xlWB = xlApp.Workbooks.Open(strPath)Set xlSheet = xlWB.Sheets("Sheet1")'Process each selected recordFor Each olItem In Application.ActiveWindow.Selection    sText = olItem.Body    vText = Split(sText, Chr(13))    'Find the next empty line of the worksheet   rCount = xlSheet.UsedRange.Rows.Count + 1      'Check each line of text in the message body    For i = UBound(vText) To 0 Step -1      rCount = rCount      If InStr(1, vText(i), "Purchase Order          :") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("A" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "Vendor                  :") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("B" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "Item Number             :") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("C" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "Vendor Quantity         :") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("D" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "SAP Quantity            :") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("E" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "Quantity UOM            :") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("F" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "Vendor Price            :") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("G" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "SAP Price               :") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("H" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "Vendor Delivery Date    :") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("I" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "SAP Delivery Date       :") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("J" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "Text here:") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("K" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "Text here:") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("L" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "Text here:") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("M" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "Text here") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("N" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "Text here") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("O" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "Text here") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("P" & rCount) = Trim(vItem(1))        End If        If InStr(1, vText(i), "Text here") > 0 Then            vItem = Split(vText(i), Chr(58))            xlSheet.Range("Q" & rCount) = Trim(vItem(1))        End If    Next i    xlWB.SaveNext olItemxlWB.Close SaveChanges:=TrueIf bXStarted ThenEnd IfSet xlApp = NothingSet xlWB = NothingSet xlSheet = NothingSet olItem = NothingEnd Sub
[/FONT][/COLOR]

 

[Legacy 296444]

Bump for one stuck guy

 

[Legacy 296444]

This would help me a ton at work