Merge multiple worksheets across the worksheet - specify range to be copied in the set copy range parameter

Merge Across

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

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

    '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 Column with data on the DestSh
            Last = LastCol(DestSh)

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

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

            'This example copies values/formats and Column width
            CopyRng.Copy
            With DestSh.Cells(1, Last + 1)
                .PasteSpecial 8    ' Column width
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

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

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