Excel VBA search for a word in a column and copy the row below the word onto a new workbook -

i trying run macro open workbook, search word apples , copy first row below word onto new workbook. in column , word "apples" comes on multiple rows. code takes word apple & row below , moves onto sheet. want move workbook , take row below. reason grabs 2 unwanted lines @ end. been fiddling not sure go here.

sub apples()      date1 = range("b3").value      chdir "c:\users\name\desktop\" & date1     workbooks.opentext filename:= _         "c:\users\name\desktop\" & date1 & "\file" & left(date1, 4), origin:= _         437, startrow:=1, datatype:=xldelimited, textqualifier:=xldoublequote, _         consecutivedelimiter:=false, tab:=true, semicolon:=false, comma:=false _         , space:=false, other:=false, fieldinfo:=array(1, 1), _         trailingminusnumbers:=true      windows("apples" & left(date1, 4)).activate     sheets.add after:=sheets(sheets.count)      const fwhat string = "apples"     dim r range, fadr string, nr long, cutrng range, ar range, long, deladr string     sheets("apples" & left(date1, 4))     set r = .range("a:a").find(fwhat, [a1], xlformulas, xlpart, , , false)     if not r nothing         fadr = r.address         set cutrng = r.offset(0, 0).resize(4, .usedrange.columns.count)                     set r = .range("a:a").findnext(r)             if r nothing exit             if r.address = fadr exit             set cutrng = union(cutrng, r.offset(0, 0).resize(4, .usedrange.columns.count))         loop     end if     if not cutrng nothing         deladr = cutrng.address         nr = 1         each ar in cutrng.areas             ar.cut destination:=sheets(.index + 1).range("a" & nr)             nr = sheets(.index + 1).range("a" & rows.count).end(xlup).row - 1         next ar         .range(deladr).delete shift:=xlup     end if end  end sub 

edit: corrected code 2 rows each time; , copy encountered rather waiting until end.

the following modified version of code. opens workbook has 'data', creates new workbook (no provision managing if existing name found), copies row search term plus next row. indicated needs copy first finds.

option explicit  sub apples() dim wbthis      workbook dim wbdata      workbook dim wbnew       workbook dim ws          worksheet dim date1       string dim strpath     string const fwhat     string = "apples" dim rngr        range, copyrng range, rnga range dim stradr      string dim lnextrow    long, long dim bfound      boolean dim rngfirst     range      date1 = range("b3").value      strpath = "c:\users\name\desktop\"     strpath = "c:\temp\"                    ' *** delete line      chdir strpath & date1      ' open workbook has data     set wbdata = workbooks.open(filename:=strpath & date1 & "\file" & left(date1, 4))      ' make sure have desired worksheet name     bfound = false     each ws in wbdata.worksheets         if ws.name = "apples" & left(date1, 4)             bfound = true             exit         end if     next ws     if bfound = false         msgbox "workbook '" & strpath & date1 & "\file" & left(date1, 4) & _             "' not contain expected sheet named '" & "apples" & left(date1, 4) & "'." & vbcrlf & vbcrlf & _             "please correct , start over.", vbokonly + vbcritical, "missing sheet"         wbdata.close         goto wrapup     end if      ' create new workbook     set wbnew = workbooks.add     application.displayalerts = false     wbnew.saveas filename:=strpath & "book123.xlsx"     application.displayalerts = true      lnextrow = 0     debug.print "--------------------"     wbdata.sheets("apples" & left(date1, 4))         set rngr = .range("a:a").find(fwhat, [a1], xlformulas, xlpart, , , false)          if not rngr nothing             set rngfirst = rngr             debug.print "first: " & rngr.address             lnextrow = 1             if not rngr nothing                 stradr = rngr.address                 set copyrng = rngr.offset(0, 0).resize(2, .usedrange.columns.count)                 debug.print "copy: " & copyrng.address                 copyrng.copy destination:=wbnew.sheets("sheet1").range("a" & lnextrow)                 lnextrow = lnextrow + 2                                      set rngr = .range("a:a").findnext(rngr)                     if rngr nothing exit                     debug.print "next : " & rngr.address                      if rngr.address = stradr exit                     set copyrng = rngr.offset(0, 0).resize(2, .usedrange.columns.count)                     debug.print "copy: " & copyrng.address                     copyrng.copy destination:=wbnew.sheets("sheet1").range("a" & lnextrow)                     lnextrow = lnextrow + 2                     'debug.print "combo before: " & copyrng.address                     'set copyrng = union(copyrng, rngr.offset(0, 0).resize(2, .usedrange.columns.count))                     'set copyrng = union(copyrng, rngr.offset(0, 0).resize(2, .usedrange.columns.count))                     'debug.print "combo after : " & copyrng.address                 loop             end if         else             msgbox " not found"             exit sub         end if     end      wbdata.close     wbnew.close  wrapup:     ' close down... end sub