excel - VBA - Search for cell, grab contents to the right of cell -
i have working macro loops through folder open files , important info columns of names "holder" , "cutting tool" , printing info 1 excel document, masterfile. prints file name column 1 , name of "tooling data sheet" column 4. have set printing cell j1.
this works of time information not in j1. want search header "tooling data sheet (tds):" have done "holder" , "cutting tool" grab contents in one cell right of header , print masterfile (as works instead of printing j1, print cell right of header). ideas?
the information "tooling data sheet" printed in second half of section (5). major commented out sections in code have been attempts @ solving issue.
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 finalrow long dim f string dim dict object dim hc range, hc1 range, hc2 range, hc3 range, hc4 range, hc5 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") set hc4 = headercell(startsht.range("d1"), "tooling data sheet (tds):") '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 instr(row_header, "holder") <> "" 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 'end if else 'header not found on source worksheet end if '''(4) ' 'find tds on source sheet ' set hc5 = headercell2(ws.cells(row_header, 1), "tooling data sheet (tds):") ' if not hc5 nothing ' set dict = getvalues(hc5.offset(1, 0)) ' 'if instr(row_header, "holder") <> "" ' if dict.count > 0 ' set d = startsht.cells(rows.count, hc4.column).end(xlup).offset(1, 0) ' 'add values master list, column 2 ' d.resize(dict.count, 1).value = application.transpose(dict.items) ' end if ' 'end if ' else ' 'header not found on source worksheet ' end if '(5) wb 'print tds information each ws in .worksheets 'print file name column 1 startsht.cells(i, 1) = objfile.name startsht.range(startsht.cells(i, 1), startsht.cells(getlastrowincolumn(startsht, "c"), 1)) = objfile.name 'print tds name j1 cell column 4 ws .range("j1").copy startsht.cells(i, 4) .range("j1").copy startsht.range(startsht.cells(i, 4), startsht.cells(getlastrowincolumn(startsht, "c"), 4)) end = getlastrowinsheet(startsht) + 1 'move next file next ws '(6) 'close, not save changes opened files .close savechanges:=false end end if '(7) 'move next file next objfile 'turn screen updating on application.screenupdating = true activewindow.scrollrow = 1 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) 'exclude info after ";" if not ismissing(vsplit) spl = split(v, ";") v = spl(0) end if 'exclude info after "," 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 'copy cell value if contains string "holder" or "cutting tool" if instr(c.value, sheader) <> 0 set rv = c exit end if next c set headercell = rv end function ''(9) ''find header on row: returns nothing if not found 'function headercell2(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(xltoright)).cells ' 'copy cell value if contains string "holder" or "cutting tool" ' if instr(c.value, sheader) <> 0 ' set rv = c ' exit ' end if ' next c ' set headercell2 = 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 edit current code attempt creating function call:
function gettdsname(theworksheet worksheet) dim ret theworksheet if application.worksheetfunction.counta(.cells) <> 0 ret = range("j1").find(what:="tooling data sheet (tds):", lookat:=xlwhole, lookin:=xlvalues).offset(, 1).value else ret = 1 end if end gettdsname = ret end function
solution:
'print tds name if not range("a1:k1").find(what:="tooling data sheet (tds):", lookat:=xlwhole, lookin:=xlvalues) nothing set tds = range("a1:k1").find(what:="tooling data sheet (tds):", lookat:=xlwhole, lookin:=xlvalues).offset(, 1) startsht.range(startsht.cells(i, 1), startsht.cells(getlastrowincolumn(startsht, "c"), 1)) = tds else startsht.range(startsht.cells(i, 1), startsht.cells(getlastrowincolumn(startsht, "c"), 1)) = "no tds value!" end if = getlastrowinsheet(startsht) + 1 end
Comments
Post a Comment