excel - VBA - print current file name in every row -
i have working macro loops through folder open files , important info columns of names "holder" , "cutting tool" , printing info 1 excel document, masterfile.
i print file name in column 1 in every row until file closes every entry in columns 2 , 3, there file name entry in column 1, , in column 4.
i have working prints name in first cell , final cell, example if column 2 had info in rows 1 thorugh 4, file name printed in first column in row 1 , row 4. need of rows in between cannot seem make work. ideas?
section (5) deal printing columns 1 , 4. recent fix line startsht.cells((getlastrowincolumn(startsht, "c")), 1) = objfile.name prints file name last cell.
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 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 '(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 '(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 '(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
answer: prints 1 file name without extension in column 4 , prints names down column 1.
set startsht = workbooks("name of file print to.xlsm").sheets("sheet1") myfolder = "c:\wherever opening files are\" set hc4 = headercell(startsht.range("a1"), "tooling data sheet (tds):") ... ... '(5) 'print file name column 4 startsht.cells(i, 4) = objfile.name ws 'print tds name searching header if not ws.range("a1:k1").find(what:="tooling data sheet (tds):", lookat:=xlwhole, lookin:=xlvalues) nothing set tds = ws.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 'print file name wihtout extension startsht.range(startsht.cells(i, 1), startsht.cells(getlastrowincolumn(startsht, "c"), 1)) = getfilenamewithoutextension(objfile.name) end if = getlastrowinsheet(startsht) + 1 end ... end sub ... '(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 '(12) 'get file name without extension function getfilenamewithoutextension(byval filename) dim result, result = filename = instrrev(filename, ".") if (i > 0) result = mid(filename, 1, - 1) end if getfilenamewithoutextension = result end function
Comments
Post a Comment