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)

before image

after image

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

Popular posts from this blog

Magento/PHP - Get phones on all members in a customer group -

php - .htaccess mod_rewrite for dynamic url which has domain names -

Website Login Issue developed in magento -