Data overlaps when merging multiple sheets - vba

Question

I have an Excel workbook which contains n sheets. I want to merge the data from each sheet to one single sheet. The header and data from the first sheet should be on top, the data from second sheet should be below it and so on. All the sheets have the same columns and headers structure. So, the header should appear only once i.e take header and data from first sheet and only data from remaining sheets. I have the following code:
Sub Combine()
'This macro will copy all rows from the first sheet
'(including headers)
'and on the next sheets will copy only the data
'(starting on row 2)
Dim i As Integer
Dim j As Long
Dim SheetCnt As Integer
Dim lstRow1 As Long
Dim lstRow2 As Long
Dim lstCol As Integer
Dim ws1 As Worksheet
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
On Error Resume Next
'Delete the Target Sheet on the document (in case it exists)
Sheets("Target").Delete
'Count the number of sheets on the Workbook
SheetCnt = Worksheets.Count
'Add the Target Sheet
Sheets.Add after:=Worksheets(SheetCnt)
ActiveSheet.Name = "Target"
Set ws1 = Sheets("Target")
lstRow2 = 1
'Define the row where to start copying
'(first sheet will be row 1 to include headers)
j = 1
'Combine the sheets
For i = 1 To SheetCnt
Worksheets(i).Select
'check what is the last column with data
lstCol = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
'check what is the last row with data
lstRow1 = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
'Define the range to copy
Range("A2:G2" & j, Cells(lstRow1, lstCol)).Select
'Copy the data
Selection.Copy
ws1.Range("A2:G2" & lstRow2).PasteSpecial
Application.CutCopyMode = False
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
'Define the new last row on the Target sheet
lstRow2 = ws1.Cells(65535, "A").End(xlUp).Row + 1
'Define the row where to start copying
'(2nd sheet onwards will be row 2 to only get data)
j = 3
Next
With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
Sheets("Target").Select
Cells.EntireColumn.AutoFit
Range("A1").Select
End Sub
With this code, my data from all sheets is getting overlapped. I want the data to be one below the other.

Answer 1

It's overlapping because you don't increment the paste area on the Target sheet
To fix the problem offset the paste area correspondingly:
Sheet 1: copy 10 rows-paste -> increment paste start & end area by 10
Sheet 2: copy 15 rows-paste -> increment paste start & end area by 25: 10 + 15 and so on...
You can also replace this:
Sheets.Add after:=Worksheets(SheetCnt) 'Add the Target Sheet
ActiveSheet.Name = "Target"
Set ws1 = Sheets("Target")
with this:
Set ws1 = Sheets.Add(after:=Worksheets(SheetCnt)) 'Add the Target Sheet
ws1.Name = "Target"
If you eliminate all "Select" statements and refer to each object explicitly it will allow you to reduce code, and un-needed complexity
Here is my version:
Option Explicit
Public Sub Combine()
Const HEADR As Byte = 1
Dim i As Long, rngCurrent As Range
Dim ws As Worksheet, wsTarget As Worksheet
Dim lCol As Long, lCel As Range
Dim lRow As Long, toLRow As Long
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
For Each ws In Worksheets 'Delete Target Sheet if it exists
With ws
If .Name = "Target" Then
.Delete
Exit For
End If
End With
Next
Set wsTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
wsTarget.Name = "Target"
Set lCel = GetMaxCell(Worksheets(1).UsedRange)
If lCel.Row > 1 Then
With Worksheets(1)
'Expected: all sheets will have the same number of columns
lCol = lCel.Column
lRow = HEADR
toLRow = HEADR
.Range(.Cells(HEADR, 1), .Cells(HEADR, lCol)).Copy
With wsTarget
.Range(.Cells(HEADR, 1), .Cells(HEADR, lCol)).PasteSpecial xlPasteAll
End With
End With
For i = 1 To Worksheets.Count 'concatenate data ---------------------------
Set lCel = GetMaxCell(Worksheets(i).UsedRange)
If lCel.Row > 1 Then
With Worksheets(i)
If .Name <> "Target" Then 'exclude the 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
With wsTarget
.Range(.Cells(toLRow, 1), _
.Cells(toLRow + (lRow - HEADR), lCol)) = _
rngCurrent.Value
End With
End If
End With
End If
Next '--------------------------------------------------------------------
With wsTarget
.Columns.AutoFit
.Range("A1").Select
End With
With Application
.CutCopyMode = False
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
End If
End Sub
Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range
'Returns the last cell containing a value, or A1 if Worksheet is empty
Const NONEMPTY As String = "*"
Dim lRow As Range, lCol As Range
If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
If WorksheetFunction.CountA(rng) = 0 Then
Set GetMaxCell = rng.Parent.Cells(1, 1)
Else
With rng
Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
After:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows)
If Not lRow Is Nothing Then
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 With
End If
End Function
'--------------------------------------------------------------------------------------
Offsetting the paste area is done by incrementing lRow and toLRow
Edit:
If you use this code and you want to transfer cell formatting for all data cells replace this section:
'copy data to Target sheet
With wsTarget
.Range(.Cells(toLRow, 1), .Cells(toLRow + (lRow - HEADR), lCol)) = _
rngCurrent.Value
End With
with this:
'copy data to Target sheet
rngCurrent.Copy
With wsTarget
With .Range(.Cells(toLRow, 1), .Cells(toLRow + (lRow - HEADR), lCol))
.PasteSpecial xlPasteAll
End With
End With
but it will become slower if you're processing a lot of sheets
EDIT: to show how to handle special cases
The above solution is more generic and dynamically detects the last column and row containing data
The number of columns (and rows) to be processed can be manually updated. For example, if your sheets contain 43 columns with data, and you want to exclude the last 2 columns, make the following change to the script:
Line
Set lCel = GetMaxCell(Worksheets(1).UsedRange)
changes to
Set lCel = Worksheets(1).UsedRange("D41")