vba - Data overlaps when merging multiple sheets -


i have excel workbook contains n sheets. want merge data each sheet 1 single sheet. header , data first sheet should on top, data second sheet should below , on. sheets have same columns , headers structure. so, header should appear once i.e take header , data first sheet , data remaining sheets. have following code:

sub combine()  'this macro copy rows first sheet '(including headers) 'and on next sheets copy data '(starting on row 2)  dim integer dim j long dim sheetcnt integer dim lstrow1 long dim lstrow2 long dim lstcol integer dim ws1 worksheet  application     .displayalerts = false     .enableevents = false     .screenupdating = false end  on error resume next  'delete target sheet on document (in case exists) sheets("target").delete 'count number of sheets on workbook sheetcnt = worksheets.count  'add target sheet sheets.add after:=worksheets(sheetcnt) activesheet.name = "target" set ws1 = sheets("target") lstrow2 = 1 'define row start copying '(first sheet row 1 include headers) j = 1  'combine sheets = 1 sheetcnt     worksheets(i).select      'check last column data     lstcol = activesheet.cells(1, activesheet.columns.count).end(xltoleft).column      'check last row data     lstrow1 = activesheet.cells(activesheet.rows.count, "a").end(xlup).row      'define range copy     range("a2:g2" & j, cells(lstrow1, lstcol)).select      'copy data     selection.copy     ws1.range("a2:g2" & lstrow2).pastespecial     application.cutcopymode = false      selection.offset(1, 0).resize(selection.rows.count - 1).select     'define new last row on target sheet     lstrow2 = ws1.cells(65535, "a").end(xlup).row + 1       'define row start copying     '(2nd sheet onwards row 2 data)     j = 3 next  application     .displayalerts = true     .enableevents = true     .screenupdating = true end  sheets("target").select cells.entirecolumn.autofit range("a1").select  end sub

with code, data sheets getting overlapped. want data 1 below other.

it's overlapping because don't increment paste area on target sheet

to fix problem offset paste area correspondingly:

  1. sheet 1: copy 10 rows-paste -> increment paste start & end area 10
  2. sheet 2: copy 15 rows-paste -> increment paste start & end area 25: 10 + 15 , on...

you can replace this:

sheets.add after:=worksheets(sheetcnt)    'add target sheet activesheet.name = "target" set ws1 = sheets("target")

with this:

set ws1 = sheets.add(after:=worksheets(sheetcnt))   'add target sheet ws1.name = "target"

if eliminate "select" statements , refer each object explicitly allow reduce code, , un-needed complexity

here version:

option explicit  public sub combine()     const headr byte = 1      dim long, rngcurrent range     dim ws worksheet, wstarget worksheet     dim lcol long, lcel range     dim lrow long, tolrow long      application         .displayalerts = false         .enableevents = false         .screenupdating = false     end      each ws in worksheets   'delete target sheet if exists         ws             if .name = "target"                 .delete                 exit             end if         end     next     set wstarget = worksheets.add(after:=worksheets(worksheets.count))     wstarget.name = "target"      set lcel = getmaxcell(worksheets(1).usedrange)     if lcel.row > 1         worksheets(1)             'expected: sheets have same number of columns             lcol = lcel.column             lrow = headr             tolrow = headr              .range(.cells(headr, 1), .cells(headr, lcol)).copy             wstarget                 .range(.cells(headr, 1), .cells(headr, lcol)).pastespecial xlpasteall             end         end          = 1 worksheets.count   'concatenate data ---------------------------             set lcel = getmaxcell(worksheets(i).usedrange)             if lcel.row > 1                 worksheets(i)                     if .name <> "target"           'exclude target                         tolrow = tolrow + lrow          'last row on target                         lrow = lcel.row                 'last row on current                         set rngcurrent = .range(.cells(headr + 1, 1), _                                                 .cells(lrow, lcol))                         lrow = lrow - headr                         wstarget                             .range(.cells(tolrow, 1), _                                    .cells(tolrow + (lrow - headr), lcol)) = _                                     rngcurrent.value                         end                     end if                 end             end if         next    '--------------------------------------------------------------------         wstarget             .columns.autofit             .range("a1").select         end         application             .cutcopymode = false             .displayalerts = true             .enableevents = true             .screenupdating = true         end     end if end sub 
public function getmaxcell(optional byref rng range = nothing) range      'returns last cell containing value, or a1 if worksheet empty      const nonempty string = "*"     dim lrow range, lcol range      if rng nothing set rng = application.activeworkbook.activesheet.usedrange     if worksheetfunction.counta(rng) = 0         set getmaxcell = rng.parent.cells(1, 1)     else         rng             set lrow = .cells.find(what:=nonempty, lookin:=xlformulas, _                                         after:=.cells(1, 1), _                                         searchdirection:=xlprevious, _                                         searchorder:=xlbyrows)             if not lrow nothing                 set lcol = .cells.find(what:=nonempty, lookin:=xlformulas, _                                             after:=.cells(1, 1), _                                             searchdirection:=xlprevious, _                                             searchorder:=xlbycolumns)                  set getmaxcell = .parent.cells(lrow.row, lcol.column)             end if         end     end if end function  '--------------------------------------------------------------------------------------

offsetting paste area done incrementing lrow , tolrow

edit:

if use code , want transfer cell formatting data cells replace section:

'copy data target sheet wstarget     .range(.cells(tolrow, 1), .cells(tolrow + (lrow - headr), lcol)) = _         rngcurrent.value end

with this:

'copy data target sheet rngcurrent.copy wstarget     .range(.cells(tolrow, 1), .cells(tolrow + (lrow - headr), lcol))         .pastespecial xlpasteall     end end

but become slower if you're processing lot of sheets

edit: show how handle special cases

the above solution more generic , dynamically detects last column , row containing data

the number of columns (and rows) processed can manually updated. example, if sheets contain 43 columns data, , want exclude last 2 columns, make following change script:

line

set lcel = getmaxcell(worksheets(1).usedrange)

changes to

set lcel = worksheets(1).usedrange("d41")


Comments

Post a Comment

Popular posts from this blog

c# - Validate object ID from GET to POST -

i have method allows user access comment have made on site. have post method lets them update comment. my normal solution send entire comment model through, let them update it, update on database when post back. involve sending commentid through in hiddenfor , can manipulated. how can verify commentid sent in get method same i'm getting in post , not able alter comment wish? how can verify commentid sent in method same i'm getting in post? basically have validate following things in post - user logged-in user. authenticated users post comments. commentid in post , should valid commentid , should present in database. userid associated logged-in user should same userid associated comment . comment should contain userid column, can check @ time of update. to make sure update happens comment has been sent in get - hold commentid in session , in post action compare commentid value in session .
Read more

node.js - Custom Model Validator SailsJS -

when using custom model validator checks record within model. return within spread doesn't seem end control flow. //post.js model /** * custom validator **/ types: { isuservalid: function(user_id) { var promise = require('bluebird'); promise.all([ user.findone({id: user_id}) ]) .spread(function(user) { console.log(user); if (user === null || user === undefined) { console.log('failed'); return false; }else{ console.log('passed'); return true; } }); } }, my response standard validation failed response. { "error": "e_validation", "status": 400, "summary": "1 attribute invalid", "model": "post", "invalidattributes": { "owner": [ { "rule": "isuservalid", ...
Read more

php - Find a regex to take part of Email -

i have following emails need extract part from: bestellnummer xxx: 1 von xxx, 1er pack ------------- anfang der nachricht ------------- foo bar baz foo bar baz // <<<<< need text here ------------- ende der nachricht ------------- ------------- anfang der nachricht ------------- foo bar baz foo bar baz ------------- ende der nachricht ------------- there 0 unlimited occurences of ------------- anfang der nachricht ------------- ------------- ende der nachricht ------------- and i'm able extract first part regex: $re = "/------------- .*? -------------.?(.*?).?------------- .*? -------------/s"; but, i'm quite new on learning regex, i'm pretty sure there must better regex extract part (foo bar baz foo bar baz) of text between ------------- anfang der nachricht ------------- ------------- ende der nachricht ------------- as can in different languages, i'm using .? to match between hyphens. i...
Read more