excelvba

Merge all worksheets used data range to a new sheet named “Master”


I have a workbook with many sheets with fixed data structure.

I want to:
First: Fill the last empty column with the sheet name on all sheets.
Second: Delete columns B, C, D, E, F (5 columns) on all sheets.
Third: Merge all worksheets used data range to a new sheet named “Master”.

INPUT DATA:

PARTICULARS H1  H2  H3  H4  H5  H6  H7  H8  H9  H10 H11 H12 H14 H15
AA          1   2   3   4   5   6   7   8   9   10  11  12  13  
BB          14  15  16  17  18  19  20  21  22  23  24  25  26  
CC          27  28  29  30  31  32  33  34  35  36  37  38  39  

SHEET NAME: |ECSTASY|BEAUTY| etc,

OUTPUT DATA:
PARTICULAR H6   H7  H8  H9  H10 H11 H12 H14 H15
AA          6   7   8   9   10  11  12  13  ECSTASY
BB          19  20  21  22  23  24  25  26  ECSTASY
CC         32   33  34  35  36  37  38  39  ECSTASY
AA         6    7   8   9   10  11  12  13  BEAUTY
BB        19    20  21  22  23  24  25  26  BEAUTY
CC        32    33  34  35  36  37  38  39  BEAUTY
etc.

I developed code. It is giving the following error

Application defined or Object defined error

on the line

ws.Range(ws.Cells(1, 1), ws.Cells(srcLastRow, srcLastCol - 5)).Copy masterWs.Cells(destLastRow, 1)
Sub CombineSheets()

Dim ws As Worksheet
Dim masterWs As Worksheet
Dim srcLastRow As Long, srcLastCol As Long
Dim destLastRow As Long

' Create the "Master" sheet
Set masterWs = ThisWorkbook.Worksheets.Add
masterWs.Name = "Master"

' Iterate through each worksheet
For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "Master" Then
        ' Fill the last empty column with the sheet name
        srcLastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1
        ws.Cells(1, srcLastCol).Value = ws.Name
        
        ' Delete columns B, C, D, E, and F
        ws.Range("B:F").Delete
        
        ' Find the last row in the source and destination sheets
        srcLastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        destLastRow = masterWs.Cells(masterWs.Rows.Count, 1).End(xlUp).Row + 1
        
        ' Copy the data from the source sheet to the "Master" sheet
        ws.Range(ws.Cells(1, 1), ws.Cells(srcLastRow, srcLastCol - 5)).Copy masterWs.Cells(destLastRow, 1)
    End If
Next ws

' Clean up
Set ws = Nothing
Set masterWs = Nothing

End Sub

Solution

  • Combine Worksheets into a Master Worksheet

    enter image description here

    Sub CombineSheets()
            
        Const DST_SHEET As String = "Master"
        Const DELETE_COLUMNS As String = "B:F"
        Const DST_SHEET_COLUMN_TITLE As String = "Sheet"
            
        Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
        
        Application.ScreenUpdating = False
        
        Dim dsh As Object
        On Error Resume Next
            Set dsh = wb.Sheets(DST_SHEET)
        On Error GoTo 0
    
        If Not dsh Is Nothing Then
            Application.DisplayAlerts = False ' delete without confirmation
                dsh.Delete
            Application.DisplayAlerts = True
        End If
        
        Dim sws As Worksheet, rCount As Long, cCount As Long
        Dim dws As Worksheet, dfCell As Range, IsFirstFound As Boolean
        
        For Each sws In wb.Worksheets
            If IsFirstFound Then ' copy all but the 1st worksheet's data only
                With sws.UsedRange
                    rCount = .Rows.Count - 1
                    If rCount > 0 Then
                        .Resize(rCount).Offset(1).Copy dfCell
                    End If
                End With
            Else ' copy the 1st worksheet (with headers)
                sws.Copy After:=wb.Sheets(wb.Sheets.Count) ' or Before:=wb.Sheets(1)
                Set dws = wb.Sheets(wb.Sheets.Count) ' or wb.Sheets(1)
                dws.Name = DST_SHEET
                With dws.UsedRange
                    rCount = .Rows.Count - 1
                    cCount = .Columns.Count
                    With .Cells(1).Offset(, cCount - 1)
                        .Copy .Offset(, 1)
                        .Offset(, 1).Value = DST_SHEET_COLUMN_TITLE
                    End With
                End With
                Set dfCell = dws.Range("A2")
                IsFirstFound = True
            End If
            If rCount > 0 Then
                dfCell.Offset(, cCount).Resize(rCount).Value = sws.Name
                Set dfCell = dfCell.Offset(rCount)
            End If
        Next sws
        
        dws.Columns(DELETE_COLUMNS).Delete xlShiftToLeft
        
        Application.ScreenUpdating = True
        
        MsgBox "Sheets combined into a Master sheet.", vbInformation
        
    End Sub