Multiple sheet splitting

[sachin482]

thanks a lot for your help i have attached the out put required and the same has been resolved as per below macro

Sub SplitData()
    Dim wbk As Workbook
    Dim wsh As Worksheet
    Dim r As Long
    Dim m As Long
    Dim col As New Collection
    Dim v As Variant
    Dim s As String
    On Error Resume Next
    For Each wsh In ThisWorkbook.Worksheets
        m = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
        For r = 4 To m
            col.Add Item:=wsh.Range("A" & r).Value, Key:=wsh.Range("A" & r).Value
        Next r
    Next wsh
    On Error GoTo 0
    Application.Cursor = xlWait
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each v In col
        ThisWorkbook.Worksheets.Copy
        Set wbk = ActiveWorkbook
        For Each wsh In wbk.Worksheets
            m = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
            For r = m To 4 Step -1
                If wsh.Range("A" & r).Value <> v Then
                    wsh.Range("A" & r).EntireRow.Delete
                End If
            Next r
                If wsh.Range("A4").Value = "" Then wsh.Delete
            Next wsh
            
            s = ThisWorkbook.Path & "\" & v & ".xlsx"
          wbk.SaveAs Filename:=s, FileFormat:=xlOpenXMLWorkbook
        wbk.Close
    Next v
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Cursor = xlDefault
End Sub