excel - VBA - If cell is empty, return empty cell for specific range -
i have function in code gets values particular range in multiple files (a range last value in column designated header) , prints them 1 worksheet, masterfile. 2 columns.
my problem have 1 value in 1 column , 8 in another. should equal each other in length need first column print 1 value cell followed 7 blank cells.
i think best way go grab first column in opened file , have both of columns print length of 1 since correct length. idea how go setting up? have been playing cannot work.
i thought set value of "tool num" column n, , have print length n (denoted section (3) , (4) of code). not know how set latter up.
here area of code playing with, goes right before section (3)
if not range("a1:a24").find(what:="tool num", lookat:=xlwhole, lookin:=xlvalues) nothing set n = ws.cells(rows.count, 1).end(xlup) in line, in masterfile printed to, have print down length of whatever column "c" hoping basis go off of printing down length of whatever column 1 in open file be. hope helpful.
startsht.range(startsht.cells(i, 1), startsht.cells(getlastrowincolumn(startsht, "c"), 1)) = tds full code:
option explicit sub loopthroughdirectory() const row_header long = 10 dim objfso object dim objfolder object dim objfile object dim dict object dim myfolder string dim f string dim startsht worksheet, ws worksheet dim wb workbook dim integer dim lastrow integer, erow integer dim height integer dim finalrow long dim hc range, hc1 range, hc2 range, hc3 range, hc4 range, d range dim tds 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("a1"), "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 if not range("a1:a24").find(what:="tool num", lookat:=xlwhole, lookin:=xlvalues) nothing '(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 'add values master list, column 3 set d = startsht.cells(rows.count, hc2.column).end(xlup).offset(1, 0) d.resize(dict.count, 1).value = application.transpose(dict.items) else startsht.cells(rows.count, hc2.column).end(xlup).offset(1, 0) = "" end if else startsht.cells(rows.count, hc2.column).end(xlup).offset(1, 0) = "no 'cutting tool' present!" 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 'add values master list, column 2 set d = startsht.cells(rows.count, hc1.column).end(xlup).offset(1, 0) d.resize(dict.count, 1).value = application.transpose(dict.items) else startsht.cells(rows.count, hc1.column).end(xlup).offset(1, 0) = "" end if else startsht.cells(rows.count, hc2.column).end(xlup).offset(1, 0) = "no 'cutting tool' present!" end if end if '(5) wb 'print file name column 4 startsht.cells(i, 4) = objfile.name ws 'print tds name searching header 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 '(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 'brings viewer top of masterfile 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 if len(v) = 0 v = "" end if ' if len(v) = "" ' 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 '(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: picture upload clarify question in comments image opened files , grabbing 2 columns "holder" , "cutting tool" here labeled number , cutting tool 
try getting last row in worksheet used range. change
function getlastrowincolumn(theworksheet worksheet, col string) theworksheet getlastrowincolumn = .range(col & .rows.count).end(xlup).row end end function to
function getlastrowinsheet(theworksheet worksheet) getlastrowincolumn = theworksheet.usedrange.rows.count end function i assume worksheets contain necessary data , not have bunch of additional cells outside desired range. example, if within a1:c10, , have values below row 10, extend way bottom of used range.
edit: you'll have make sure update references function. move single line of code being called , save few more lines.
Comments
Post a Comment