Data overlaps when merging multiple sheets

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:

1. Sheet 1: copy 10 rows-paste -> increment paste start & end area by 10
2. 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")