VBA - Copy Data to Master Sheet and Insert Sheet Name Next to Each Row

Question

I have multiple sheets, each with data only in the first two columns:

Column A - ID

Column B - Name

I am trying to consolidate all these sheets into a master sheet. The format of the master sheet should be:

Column A - Sheet Name (From where the data was copied)

Column B - ID

Column C - Name

I have found a site that has code that does more or less this, however, after messing around with it for what feels like an eternity I just cannot get it to work.

The code works, in the sense that it copies the correct range and inputs the sheet name into column A, however, it doesn't stop by the "last row" of the range in the master sheet, it continues to populate the ENTIRE column A and the IF Statement that counts the rows is triggered and I get the msgbox pop up (see below in code). At this point, the code just ends and it does not get a chance to execute for the remaining sheets.

Link to site: https://www.rondebruin.nl/win/s3/win002.htm

Below is the code from the original site, with some minor adjustments for the range I will be using:

Sub CopySheetNameToColumn()
Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Delete the sheet "RDBMergeSheet" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "RDBMergeSheet"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then

            'Find the last row with data on the DestSh
            Last = LastRow(DestSh)

            'Fill in the range that you want to copy
            Set CopyRng = sh.Range("A:B")

            'Test if there enough rows in the DestSh to copy all the data
            If Last + CopyRng.Rows.count > DestSh.Rows.count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
            End If

            'This example copies values/formats, if you only want to copy the
            'values or want to copy everything look at the example below this macro
            CopyRng.Copy
            With DestSh.Cells(Last + 1, "B")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

            'Optional: This will copy the sheet name in the H column
            DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.count).Value = sh.Name

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

Functions:

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

Answer 1

Instead of

Set CopyRng = sh.Range("A:B")

try

Set CopyRng = sh.Range("A1", sh.Range("B" & Rows.Count).End(xlUp))

as the former covers every row of the worksheet, hence the message box and the name running down the whole sheet.

Answer 2

Something like:

Option Explicit

Sub CopySheetNameToColumn()

    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True


    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"

    For Each sh In ActiveWorkbook.Worksheets

        If sh.Name <> DestSh.Name Then

            Last = GetLastRow(DestSh, 1)

            With sh
                Set CopyRng = sh.Range("A1:B" & GetLastRow(sh, 1))
            End With

            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
            Else

               CopyRng.Copy IIf(Last = 1, DestSh.Cells(1, "B"), DestSh.Cells(Last + 1, "B"))

            End If

            If Last = 1 Then
                DestSh.Cells(Last, "A").Resize(CopyRng.Rows.Count).Value = sh.Name
            Else
                 DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.Count).Value = sh.Name
            End If

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub


Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long

    With ws

      GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row

    End With

End Function

Answer 3

You can shorten this significantly... there are lots of posts about getting items on a master sheet, 4 from yesterday alone.

Take a look at this:

Dim lrSrc As Long, lrDst As Long, i As Long
For i = 1 To Sheets.Count
    If Not Sheets(i).Name = "Destination" Then
        lrSrc = Sheets(i).Cells(Sheets(i).Rows.Count, "A").End(xlUp).Row
        lrDst = Sheets("Destination").Cells(Sheets("Destination").Rows.Count, "A").End(xlUp).Row
        With Sheets(i)
            .Range(.Cells(2, "A"), .Cells(lrSrc, "B")).Copy Sheets("Destination").Range(Sheets("Destination").Cells(lrDst + 1, "B"), Sheets("Destination").Cells(lrDst + 1 + lrSrc, "C")) 'Assumes headers in first row aren't being copied
            Sheets("Destination").Range(Sheets("Destination").Cells(lrDst + 1, "A"), Sheets("Destination").Cells(lrDst + 1 + lrSrc, "A")).Value = Sheets(i).Name
        End With
    End If
 Next i

Code now tested