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

Question

I received help with this question here:

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

But I need to add another condition to this sub.

Currently what happens is that the macro will copy the data from column A and Column B of all the sheets in the workbook and paste them in column B and Column C of the Summary sheet, and in column A will be the name of the worksheet from where the data was copied from.

However, there are two sheets that do not have data in column B and as such, the only data that is copied is that of row 2. In the macro below, I have added a condition that looks for these two sheet names and it excludes them from the macro, but I need to apply the same copy/paste method with these sheets too.

And, another issue, im assuming not too big an issue, is that when the first sheet is copied, it deletes the headers on the summary sheet, but when every other sheet is copied, its pasted below the last cell with data in it..

Here is the code:

Sub ThirdParty_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 "Summary" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Summary").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

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

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets

        If sh.Name <> DestSh.Name And sh.Name <> "fakeSheet1" And sh.Name <> "fakeSheet2" 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("A2", sh.Range("B" & Rows.count).End(xlUp))

            '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

            This will copy the sheet name in the A 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

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

"(..)but I need to apply the same copy/paste method with these sheets too." - please specify your question. Also, don't post your whole code, reduce it to the part you have problems with. — David G
Can you do Set copyRng = sh.Range("A2", sh.Range("A" & sh.Rows.Count).End(xlUp).Offset(, 1)) — QHarr
Thank you for the reply @QHarr. I see that SJR had included your recommendation in their answer below too. It works thank you :) — Eitel Dagnin

SJR SJR · Accepted Answer · 2018-04-13T09:14:43

This should address the first point - comment added on the CopyRng line.

Sub ThirdParty_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("Summary").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary"
'Sample headers for DestSh
DestSh.Range("A1:C1").Value = Array("One", "Two", "Three")

For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name Then
        Last = lastRow(DestSh)
        'Base the range on the number of rows in col A and resize to add col B
        Set CopyRng = sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp)).Resize(, 2)
        If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
            MsgBox "There are not enough rows in the Destsh"
            GoTo ExitTheSub
        End If
        CopyRng.Copy
        With DestSh.Cells(Last + 1, "B")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With
        DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.Count).Value = sh.Name
    End If
Next

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

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

End Sub

On your second question, you are creating the sheet in the code so when you start it will be blank - I have added a line for some headers.

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

1 Answers