Macro for advance filter to create separate worksheet and workbook based on criteria

[bossrockzz]

Hi , I'm trying to create worksheet based on the criteria . It is creating the worksheet based on the criteria but it is not copying the data to respective worksheet
. I want S.no also to arranaged correctly in all the worksheet . I have attached the sample workbook along with it .


I also want to know whether it is possible to create workbook using this code by changing worksheet to workbook . Sorry if my question is stupd . i'm not good in Vba . I'm learning it

Option Explicit
 Sub ExtractToSheets()
    Dim ws     As Worksheet
    Dim wsNew  As Worksheet
    Dim rData  As Range
    Dim rCl    As Range
    Dim sNm    As String
    Set ws = Sheet1
     
     'extract a list of unique names
     'first clear existing list
    With ws
        Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 4).End(xlUp))
        .Columns(.Columns.Count).Clear
        .Range(.Cells(4, 4), .Cells(.Rows.Count, 4).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(4, .Columns.Count), Unique:=True
         
        For Each rCl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
            sNm = rCl.Text
             'add new sheet
            If WksExists(sNm) Then
                 'so clear contents
                Sheets(sNm).Cells.Clear
            Else
                 'new sheet required
                Set wsNew = Sheets.Add
                wsNew.Move After:=Worksheets(Worksheets.Count) 'move to end
                wsNew.name = sNm
            End If
             'AutoFilter & copy to relevant sheet
            rData.AutoFilter Field:=2, Criteria1:=sNm
            rData.Copy Destination:=Worksheets(sNm).Cells(1, 1)
        Next rCl
    End With
    ws.Columns(Columns.Count).ClearContents 'remove temporary list
    rData.AutoFilter 'switch off AutoFilter
End Sub
 
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).name) > 0)
End Function