Outlook to excel VBA stops searching body after first match -

Outlook to excel VBA stops searching body after first match -

i wrote code pull info outlook excel, , 80% working :) pull info not whole email.

i receive emails in same format pricing , other info on them. these purchase orders have more 1 line usually. in 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 not match po line item 00001

vendor cost : usd 0.00 1 ea

sap cost : usd 0.01 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 cost : usd 3.90 1 ea

sap cost : usd 3.90 1 ea

vendor delivery date : 20.09.2014

sap delivery date : 20.09.2014

action request :

quantity , requested date matched po. item 00002

as can see code pulling multiple things these emails have same origin string. after pulls line 1, code moves next email without searching entire body of email farther matches. how can prepare this? stuck :)

option explicit sub copytoexcel() dim xlapp object dim xlwb object dim xlsheet object dim olitem outlook.mailitem dim vtext variant dim stext string dim vitem variant dim long dim rcount long dim bxstarted boolean const strpath string = "excel filepath here" 'the path of workbook if application.activeexplorer.selection.count = 0 msgbox "no items selected!", vbcritical, "error" exit sub end if on error resume next set xlapp = getobject(, "excel.application") if err <> 0 application.statusbar = "please wait while excel source opened ... " set xlapp = createobject("excel.application") bxstarted = true end if on error goto 0 'open workbook input info set xlwb = xlapp.workbooks.open(strpath) set xlsheet = xlwb.sheets("sheet1") 'process each selected record each olitem in application.activewindow.selection stext = olitem.body vtext = split(stext, chr(13)) 'find next empty line of worksheet rcount = xlsheet.usedrange.rows.count + 1 'check each line of text in message body = ubound(vtext) 0 step -1 rcount = rcount if instr(1, vtext(i), "purchase order :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("a" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "vendor :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("b" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "item number :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("c" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "vendor quantity :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("d" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "sap quantity :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("e" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "quantity uom :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("f" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "vendor cost :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("g" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "sap cost :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("h" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "vendor delivery date :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("i" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "sap delivery date :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("j" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "text here:") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("k" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "text here:") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("l" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "text here:") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("m" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "text here") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("n" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "text here") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("o" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "text here") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("p" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "text here") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("q" & rcount) = trim(vitem(1)) end if next xlwb.save next olitem xlwb.close savechanges:=true if bxstarted end if set xlapp = nil set xlwb = nil set xlsheet = nil set olitem = nil end sub

code: option explicit sub copytoexcel() dim xlapp object dim xlwb object dim xlsheet object dim olitem object dim vtext variant dim stext string dim vitem variant dim long dim j long dim rcount long dim bxstarted boolean const strpath string = "excel filepath here" 'the path of workbook if application.activeexplorer.selection.count = 0 msgbox "no items selected!", vbcritical, "error" exit sub end if on error resume next set xlapp = getobject(, "excel.application") if err <> 0 application.statusbar = "please wait while excel source opened ... " set xlapp = createobject("excel.application") bxstarted = true end if on error goto 0 'open workbook input info set xlwb = xlapp.workbooks.open(strpath) set xlsheet = xlwb.sheets("sheet1") 'process each selected record j = 1 application.activeexplorer.selection.count set olitem = application.activeexplorer.selection.item(j) if olitem.class = 43 stext = olitem.body vtext = split(stext, chr(13)) 'find next empty line of worksheet rcount = xlsheet.usedrange.rows.count + 1 'check each line of text in message body = ubound(vtext) 0 step -1 if instr(1, vtext(i), "purchase order :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("a" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "vendor :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("b" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "item number :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("c" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "vendor quantity :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("d" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "sap quantity :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("e" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "quantity uom :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("f" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "vendor cost :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("g" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "sap cost :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("h" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "vendor delivery date :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("i" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "sap delivery date :") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("j" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "text here:") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("k" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "text here:") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("l" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "text here:") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("m" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "text here") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("n" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "text here") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("o" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "text here") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("p" & rcount) = trim(vitem(1)) end if if instr(1, vtext(i), "text here") > 0 vitem = split(vtext(i), chr(58)) xlsheet.range("q" & rcount) = trim(vitem(1)) end if next xlwb.save rcount = rcount + 1 end if next j xlwb.close savechanges:=true if bxstarted end if set xlapp = nil set xlwb = nil set xlsheet = nil set olitem = nil end sub

this should work. reason outlook stop execution without error if encounters non-mail item in selection.

copy , paste whole thing (even dim statements).

excel vba email outlook extract