vba - Extract Cells content in the first Excel File based on Worksheet in another File -

in first excel file multiple cells in column c contains address , name of company; want keep company name. that, have excel file (i'll call "dictionary"), has particular structure following:

column b : name want keep. column c : various patterns of name, delimited ";". example : b1 = "sony", c1="sony entertainement;sony pictures;playstation" 

i need vba macro reading dictionary file, each pattern (surrounded anything) replace word want keep.

my macro :

sub macroclear()     <for each line of dictionnary>         arrayc = split(<cell c of line>, ";")         <for in range arrayc>            cells.replace what:="*"&trim(arrayc(i))&"*", replacement:=trim(<cell b of line>), lookat:= _               xlpart, searchorder:=xlbyrows, matchcase:=false, searchformat:=false, _               replaceformat:=false end sub 

edit - update : made capture of first dictionary, it'll easier understand structure :

dictionnary http://img11.hostingpics.net/pics/403257dictionnary.png

edit - update 2 : made screen cap of "non-cleaned" file, result want @ end.

not cleaned : noclean http://img11.hostingpics.net/pics/418501notcleaned.png

cleaned :     clean http://img11.hostingpics.net/pics/221530cleaned.png

ps : know macro analyze cells of worksheet, possible "easily" tell ignore column ?

edit - update 3 : macro runs small dictionaries, when grows bigger, macro doesn't stop running , have close excel ctrl + alt + suppr. :x there way tell stop when reaching point ?

for example, using xlbyrows , writing "end" @ first cell after last row.

this literal translation of shown :

sub macroclear()  dim wbd workbook, _     wbc workbook, _     wsd worksheet, _     wsc worksheet, _     dic() string 'replace names in here yours set wbd = workbooks("dictionnary") set wbc = workbooks("filetoclean") set wsd = wbd.worksheets("name1") set wsc = wbc.worksheets("name2")  = 1 wsd.range("c" & wsd.rows.count).end(xlup).row     dic = split(wsd.cells(i, 3), ";")     k = 1 wsc.range("c" & wsc.rows.count).end(xlup).row        cells.replace what:=trim(dic(i)), _             replacement:=trim(wsd.cells(i, 2)), _             lookat:=xlpart, _             searchorder:=xlbyrows, _             matchcase:=false, _             searchformat:=false, _             replaceformat:=false     next k next  set wbd = nothing set wbc = nothing set wsd = nothing set wsc = nothing  end sub 

and updated version :

sub macroclear()  dim wbd workbook, _     wbc workbook, _     wsd worksheet, _     wsc worksheet, _     dicc() variant, _     dic() string, _     valtoreplace string, _     isindic boolean, _     rcell range  'replace names in here yours set wbd = workbooks.open("d:\users\maw\documents\resources\dict.xlsx", readonly:=true) set wbc = workbooks("testvba") set wsd = wbd.worksheets("name1") set wsc = wbc.worksheets("name2") 'set global dictionnary dimension redim dicc(1, 0)  = 1 wsd.range("c" & wsd.rows.count).end(xlup).row     dic = split(wsd.cells(i, 3), ";")     valtoreplace = trim(wsd.cells(i, 2))     k = lbound(dic) ubound(dic)         isindic = false         l = lbound(dicc, 2) ubound(dicc, 2)             if lcase(dicc(1, l)) <> trim(lcase(dic(k)))                 'no match             else                 'match                 isindic = true                 exit             end if         next l         if isindic             'don't add dicc         else             dicc(0, ubound(dicc, 2)) = trim(dic(k))             dicc(1, ubound(dicc, 2)) = valtoreplace             redim preserve dicc(ubound(dicc, 1), ubound(dicc, 2) + 1)         end if     next k next  redim preserve dicc(ubound(dicc, 1), ubound(dicc, 2) - 1) wbd.close erase dic   each rcell in wsc.range("c2:c" & wsc.range("c" & wsc.rows.count).end(xlup).row).end(xlup).row     l = lbound(dicc, 2) ubound(dicc, 2)         if instr(1, rcell.value2, dicc(0, l)) <> 0             rcell.value2 = dicc(1, l)         else             'not found         end if     next l next rcell   erase dicc set wbd = nothing set wbc = nothing set wsd = nothing set wsc = nothing  end sub