excel - Printing in one column only if the next row is empty -
i have information printed files in folder columns 1,2,3, , 4 of excel sheet. columns 1 , 2 ever contain 1 cell of information 2 , 3 vary in length equal each other.
my goal if column a, if cell next in column b occupied, go row below , loop, else if cell empty print info column 1 in row.
here full code!
option explicit sub loopthroughdirectory() 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 'turn screen updating off - makes program faster 'application.screenupdating = false 'location of folder in desired tds files myfolder = "c:\users\trembos\documents\tds\progress\" 'set startsht = activesheet set startsht = workbooks("masterfile.xlsm").sheets("sheet1") 'create instance of filesystemobject set objfso = createobject("scripting.filesystemobject") 'get folder object set objfolder = objfso.getfolder(myfolder) = 1 '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) 'print file name column 1 workbooks.open filename:=myfolder & objfile.name set wb = activeworkbook '(3) 'copy holder column f11 (11, 6) until empty lastrow = cells(rows.count, 1).end(xlup).row range(cells(11, 6), cells(lastrow, 6)).copy startsht.activate 'print holder column column 2 in masterfile in next available row range("b" & rows.count).end(xlup).offset(1).pastespecial wb.activate '(4) 'copy cutting tool column f11 (11, 7) until empty lastrow = cells(rows.count, 1).end(xlup).row range(cells(11, 7), cells(lastrow, 7)).copy startsht.activate 'print cutting tool column column 3 in masterfile in next available row range("c" & rows.count).end(xlup).offset(1).pastespecial wb.activate '(5) 'print tds information wb each ws in .worksheets 'print file name column 1 startsht.cells(i + 1, 1) = objfile.name 'print tds name column 4 ws .range("j1").copy startsht.cells(i + 1, 4) end = + 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
my ultimate goal excel sheet this: (before , after)
let's see if gets closer:
'(2) 'print file name column 1 set wb = workbooks.open filename:=myfolder & objfile.name set ws = wb.activesheet '(3) 'copy holder column f11 (11, 6) until empty ws lastrow = getlastrowincolumn(ws, "a") .range(.cells(11,6), .cells(lastrow, 6)).copy end dim destination lastrow = getlastrowincolumn(startsht, "b") set destination = startsht.range("b" & lastrow).offset(1) 'print holder column column 2 in masterfile in next available row destination.pastespecial '(4) 'redefine destination range paste column c lastrow = getlastrowincolumn(startsht, "c") set destination = startsht.range("c" & lastrow).offset(1) ws 'copy cutting tool column f11 (11, 7) until empty lastrow = getlastrowincolumn(ws, "g") 'print cutting tool column column 3 in masterfile in next available row .range(.cells(11, 7), .cells(lastrow, 7)).copy _ destination:=destination end '(5) wb 'print tds information each ws in .worksheets 'determine last row in sheet, +1 next empty row = getlastrowinsheet(ws) +1 'print file name column 1 startsht.cells(i, 1) = objfile.name 'print tds name column 4 ws .range("j1").copy startsht.cells(i, 4) end 'move next file next ws '(6) 'close, not save changes opened files .close savechanges:=false end
the important part we're not incrementing i
one, we're using getlastrowinsheet
function (below) reset i
last row in worksheet + 1.
i = getlastrowinsheet(ws) + 1
you'll need include these 2 functions, purpose of simplify clunky (and repetitive) way you're determining lastrow
. (borrowed this awesome answer)
function getlastrowincolumn(theworksheet worksheet, col string) theworksheet getlastrowincolumn = .range(col & .rows.count).end(xlup).row end end function 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
Comments
Post a Comment