Option Explicit

Sub сортируйМеняПолностью()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim r As Range
    Dim r1 As Range
    Dim iY As Integer
    Dim s1 As String
    Dim i As Integer
    Dim j As Integer
    
    Application.ScreenUpdating = False
    
    Set sh1 = ActiveSheet
    Sheets.Add after:=Sheets(Sheets.Count)
    Set sh2 = Sheets(Sheets.Count)
    
    With sh1
        Set r = Intersect(.UsedRange, .Range(.Cells(2, 2), .Cells(Rows.Count, 2)))
    End With
    
    r.Copy sh2.Cells(1)
    
    With sh2
'        .UsedRange.Resize(, 4).NumberFormat = "@"
        For iY = 1 To .UsedRange.Rows.Count
            s1 = .Cells(iY, 1).Text
            s1 = Mid(s1, 3)
            i = InStr(s1, "/")
            If i > 0 Then
                j = InStr(s1, "-")
                .Cells(iY, 2).Value = Left(s1, i - 1)
                If j > 0 Then
                    .Cells(iY, 2).Value = Left(s1, j - 1)
                Else
                    .Cells(iY, 2).Value = Left(s1, i - 1)
                End If
                                
                s1 = Mid(s1, i + 1)
                i = InStr(s1, "/")
                If i > 0 Then
                    .Cells(iY, 3).Value = Left(s1, i - 1)
                    
                    .Cells(iY, 4).Value = Mid(s1, i + 1)
                End If
                
                
                
            End If
        Next
        
        With .Sort
            With .SortFields
                .Clear
                .Add Key:=Intersect(.Parent.Parent.UsedRange, .Parent.Parent.Columns(4)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Add Key:=Intersect(.Parent.Parent.UsedRange, .Parent.Parent.Columns(3)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Add Key:=Intersect(.Parent.Parent.UsedRange, .Parent.Parent.Columns(2)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            End With
            
            .SetRange .Parent.UsedRange
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        Intersect(.UsedRange, .Columns(1)).Copy r
        
    End With
    
    Application.DisplayAlerts = False
    sh2.Delete
    Application.DisplayAlerts = True
    sh1.Activate
    Application.ScreenUpdating = True
    
End Sub