File Split Macro Adjustment Needed

[fgbdrum]

Hello,
VBA novice here. Found this code and adjusted it to fit my needs but it's not quite hitting the mark. Needs a slight tweak.
Macro is supposed to split master file in to separate ones at every change in Supervisor name. Header row is being copied to new file, but no other data. Can't figure out why.
Sample workbook attached. Thank you in advance for any and all help.

Sub MeritSplit()

Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, key As Variant, LastRow As Long, srcWB As Workbook
    Set srcWB = ThisWorkbook
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each Rng In Range("A2", Range("A" & Rows.Count).End(xlUp))
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next
    For Each key In RngList
        srcWB.Sheets("All Employees - 422S").Copy
        With ActiveSheet
            .Name = key
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("A2:Y" & LastRow).Borders.LineStyle = xlNone
            .Cells(1, 1).CurrentRegion
            .Cells(1, 1).AutoFilter 1, "<>" & key
            .Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.ClearContents
        End With
        Cells(1, 1).AutoFilter
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add key:=Range("A2:A" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending
            .SetRange Range("A2:Y" & LastRow)
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        With ActiveSheet
            .Columns.AutoFit
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("A2:Y" & LastRow).Borders.LineStyle = xlContinuous
        End With
        ActiveWorkbook.SaveAs Filename:="C:\Users\SCE01193\Desktop\Desktop\CAN Salary Planning\2023\merit files\" & key & " Merit File.xlsx", FileFormat:=51
        ActiveWorkbook.Close False
    Next key
    Application.ScreenUpdating = True
    
End Sub

[torachan]

please release the file so that it can be opened
Screenshot 2022-09-18 165548.png

[fgbdrum]

Reattaching new version of workbook here.

[torachan]

I altered the save line to the code below and it saved four individual workbooks to my desktop suitable named.
is it the fact you call '\Desktop\Desktop' a double call.

ActiveWorkbook.SaveAs Filename:="C:\Users\Steve\Desktop\" & key & " Merit File.xlsx", FileFormat:=51

[Marc L]

According to the attachment an Excel basics VBA demonstration as a beginner starter :

Sub Demo1()
    With Application
       .DisplayAlerts = False
       .ScreenUpdating = False
    With [A1].CurrentRegion.Columns
       .Item(1).AdvancedFilter 2, , .Cells(1, .Count + 3), True
        Workbooks.Add xlWBATWorksheet
    For Each V In Range(.Cells(2, .Count + 3), .Cells(1, .Count + 3).End(xlDown)).Value
       .Cells(2, .Count + 3) = V
       .AdvancedFilter 2, .Cells(1, .Count + 3).Resize(2), [A1].CurrentRegion.Rows(1)
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & V, 51
    Next
       .Cells(1, .Count + 3).CurrentRegion.Clear
    End With
        ActiveWorkbook.Close
       .DisplayAlerts = True
       .ScreenUpdating = True
    End With
End Sub 

► Do you like it ? ► ► So thanks to click on bottom left star icon ? ★ Add Reputation ? ! ◄ ◄