excel - VBA - Copy value if cell CONTAINS certain value rather than equal to or not equal to -
i have working macro loops through folder open files , important info columns of names "holder" , "cutting tool" , printing info 1 excel document, masterfile.
i have run problem in “holder” column, there information “holder / toolbox” not consistent. have working “holder” wondering if possible still regardless of if there text in holder header name or if lowercase rather capitals. thank can provide!
this code deals "holder" section. below full code better reference (section 4 regards section tinkering , section 8 function references).
'find headers on sheet set hc1 = headercell(startsht.range("b1"), "holder") ... '(4) 'find holder on source sheet set hc3 = headercell(ws.cells(row_header, 1), "holder") if not hc3 nothing set dict = getvalues(hc3.offset(1, 0)) if dict.count > 0 set d = startsht.cells(rows.count, hc1.column).end(xlup).offset(1, 0) 'add values master list, column 2 d.resize(dict.count, 1).value = application.transpose(dict.items) end if else 'header not found on source worksheet end if ... '(8) 'get unique column values starting @ cell c function getvalues(ch range, optional vsplit variant) object dim dict object dim rng range, c range dim v dim spl variant set dict = createobject("scripting.dictionary") each c in ch.parent.range(ch, ch.parent.cells(rows.count, ch.column).end(xlup)).cells v = trim(c.value) if len(v) > 0 , not dict.exists(v) if not ismissing(vsplit) spl = split(v, ";") v = spl(0) end if if not ismissing(vsplit) spl = split(v, ",") v = spl(0) end if dict.add c.address, v end if next c set getvalues = dict end function full code
option explicit sub loopthroughdirectory() const row_header long = 10 dim objfso object dim objfolder object dim objfile object dim myfolder string dim startsht worksheet, ws worksheet dim wb workbook dim integer dim lastrow integer, erow integer dim height integer dim rowlast long dim f string dim dict object dim hc range, hc1 range, hc2 range, hc3 range, d range set startsht = workbooks("masterfile.xlsm").sheets("sheet1") 'turn screen updating off - makes program faster application.screenupdating = false 'location of folder in desired tds files myfolder = "c:\users\trembos\documents\tds\progress\" 'find headers on sheet set hc1 = headercell(startsht.range("b1"), "holder") set hc2 = headercell(startsht.range("c1"), "cutting tool") 'create instance of filesystemobject set objfso = createobject("scripting.filesystemobject") 'get folder object set objfolder = objfso.getfolder(myfolder) = 2 'loop through directory file , print names '(1) each objfile in objfolder.files if lcase(right(objfile.name, 3)) = "xls" or lcase(left(right(objfile.name, 4), 3)) = "xls" '(2) 'open folder , file name, not update links set wb = workbooks.open(filename:=myfolder & objfile.name, updatelinks:=0) set ws = wb.activesheet '(3) 'find cutting tool on source sheet set hc = headercell(ws.cells(row_header, 1), "cutting tool") if not hc nothing set dict = getvalues(hc.offset(1, 0), "splitme") if dict.count > 0 set d = startsht.cells(rows.count, hc2.column).end(xlup).offset(1, 0) 'add values master list, column 3 d.resize(dict.count, 1).value = application.transpose(dict.items) end if else 'header not found on source worksheet end if '(4) 'find holder on source sheet set hc3 = headercell(ws.cells(row_header, 1), "holder") if not hc3 nothing set dict = getvalues(hc3.offset(1, 0)) if dict.count > 0 set d = startsht.cells(rows.count, hc1.column).end(xlup).offset(1, 0) 'add values master list, column 2 d.resize(dict.count, 1).value = application.transpose(dict.items) end if else 'header not found on source worksheet end if '(5) 'print filename , tds information wb each ws in .worksheets 'print file name column 1 startsht.cells(i, 1) = objfile.name startsht.cells((getlastrowincolumn(startsht, "c")), 1) = objfile.name 'print tds name j1 cell column 4 ws .range("j1").copy startsht.cells(i, 4) end = getlastrowinsheet(startsht) + 1 'move next file next ws '(6) 'close, not save changes opened files .close savechanges:=false end end if 'move next file next objfile 'turn screen updating on application.screenupdating = true activewindow.scrollrow = 1 '(7) end sub '(8) 'get unique column values starting @ cell c function getvalues(ch range, optional vsplit variant) object dim dict object dim rng range, c range dim v dim spl variant set dict = createobject("scripting.dictionary") each c in ch.parent.range(ch, ch.parent.cells(rows.count, ch.column).end(xlup)).cells v = trim(c.value) if len(v) > 0 , not dict.exists(v) if not ismissing(vsplit) spl = split(v, ";") v = spl(0) end if if not ismissing(vsplit) spl = split(v, ",") v = spl(0) end if dict.add c.address, v end if next c set getvalues = dict end function '(9) 'find header on row: returns nothing if not found function headercell(rng range, sheader string) range dim rv range, c range each c in rng.parent.range(rng, rng.parent.cells(rng.row, columns.count).end(xltoleft)).cells if trim(c.value) = sheader set rv = c exit end if next c set headercell = rv end function '(10) function getlastrowincolumn(theworksheet worksheet, col string) theworksheet getlastrowincolumn = .range(col & .rows.count).end(xlup).row end end function '(11) function getlastrowinsheet(theworksheet worksheet) dim ret theworksheet if application.worksheetfunction.counta(.cells) <> 0 ret = .cells.find(what:="*", _ after:=.range("a1"), _ lookat:=xlpart, _ lookin:=xlformulas, _ searchorder:=xlbyrows, _ searchdirection:=xlprevious, _ matchcase:=false).row else ret = 1 end if end getlastrowinsheet = ret end function
the part needs adjusting part searches header row, comparing values. looks in headercell function. specific line looks comparison is:
if trim(c.value) = sheader this comparing contents of each cell in header row passed in value (in case sheader = "holder").
you better off doing test see if sheader in cell value, not equal cell value. instr function perfect this. along lines of (untested air code):
if instr(c.value, sheader) <> 0 this search contents of each cell in header row, looking see if value passed in sheader anywhere in value.
Comments
Post a Comment