Excel Macro Sort Alphabetically

Option Explicit
Sub SortEmployeeBlocks()
    Const SRC_SHEET  As String = "Pay Stub Report"   '← edit if needed
    Const OUT_SHEET  As String = "Sorted Report"
    Const FOOTER_TAG As String = "Generated"         'first cell that marks the footer

    Dim wsIn As Worksheet, wsOut As Worksheet
    Dim lastRow As Long, lastCol As Long, r As Long
    Dim footerRow As Long, headerRows As Long
    Dim blkStarts As Collection
    Dim blocks() As Range, names() As String
    Dim i As Long, j As Long, destRow As Long

    Set wsIn = ThisWorkbook.Worksheets(SRC_SHEET)
    lastRow = wsIn.Cells(wsIn.Rows.Count, "A").End(xlUp).Row
    lastCol = wsIn.Cells(1, wsIn.Columns.Count).End(xlToLeft).Column

    '--- locate the footer (“Generated …”) ---------------------------
    For r = lastRow To 1 Step -1
        If InStr(1, wsIn.Cells(r, 1).Text, FOOTER_TAG, vbTextCompare) > 0 Then
            footerRow = r
            Exit For
        End If
    Next r
    If footerRow = 0 Then MsgBox "Footer '" & FOOTER_TAG & "' not found.": Exit Sub

    '--- find every “Name” row (start of employee blocks) ------------
    Set blkStarts = New Collection
    For r = 1 To footerRow - 1
        If wsIn.Cells(r, 1).Value = "Name" Then blkStarts.Add r
    Next r
    If blkStarts.Count = 0 Then MsgBox "No rows where A = 'Name' found.": Exit Sub
    blkStarts.Add footerRow          'sentinel so we know where each block ends

    '--- slice blocks into arrays ------------------------------------
    ReDim blocks(1 To blkStarts.Count - 1)
    ReDim names(1 To blkStarts.Count - 1)

    For i = 1 To blkStarts.Count - 1
        Dim sRow As Long, eRow As Long
        sRow = blkStarts(i)
        eRow = blkStarts(i + 1) - 1
        Set blocks(i) = wsIn.Range(wsIn.Rows(sRow), wsIn.Rows(eRow))
        names(i) = wsIn.Cells(sRow, 2).Text
    Next i

    '--- simple alphabetic sort of names + blocks --------------------
    Dim tmpName As String, tmpRng As Range
    For i = LBound(names) To UBound(names) - 1
        For j = i + 1 To UBound(names)
            If StrComp(names(i), names(j), vbTextCompare) > 0 Then
                tmpName = names(i): names(i) = names(j): names(j) = tmpName
                Set tmpRng = blocks(i): Set blocks(i) = blocks(j): Set blocks(j) = tmpRng
            End If
        Next j
    Next i

    '--- nuke / recreate output sheet --------------------------------
    Application.DisplayAlerts = False
    On Error Resume Next: Worksheets(OUT_SHEET).Delete: On Error GoTo 0
    Application.DisplayAlerts = True
    Set wsOut = Worksheets.Add(After:=wsIn)
    wsOut.Name = OUT_SHEET

    '--- copy header rows straight over ------------------------------
    headerRows = blkStarts(1) - 1
    If headerRows > 0 Then
        wsIn.Range(wsIn.Rows(1), wsIn.Rows(headerRows)).Copy wsOut.Range("A1")
    End If
    destRow = headerRows + 1

    '--- copy each sorted employee block -----------------------------
    For i = LBound(blocks) To UBound(blocks)
        blocks(i).Copy wsOut.Cells(destRow, 1)
        destRow = destRow + blocks(i).Rows.Count
    Next i

    '--- copy footer (“Generated …”) ---------------------------------
    wsIn.Range(wsIn.Rows(footerRow), wsIn.Rows(lastRow)).Copy wsOut.Cells(destRow, 1)

    '--- mirror column widths ----------------------------------------
    Dim c As Long
    For c = 1 To lastCol
        wsOut.Columns(c).ColumnWidth = wsIn.Columns(c).ColumnWidth
    Next c

    MsgBox "Done! Blocks sorted, footer preserved on '" & OUT_SHEET & "'."
End Sub