Перенести на новый лист строки с определенным именем, и переименовать лист

Option Explicit
 
Sub PereborStrok()    'коллекция в словаре
    Dim a, i&, x&, t$, NewSheet As Object
    Dim el, col
 
    With Sheets(1)
        a = .Range("C1", .Cells(.Rows.Count, "A").End(xlUp)).Value
    End With
 
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
 
        For i = 1 To UBound(a)
            t = a(i, 2)
            If Not .exists(t) Then .Add t, New Collection
            .Item(t).Add i
        Next
 
        For Each el In .keys
            Set NewSheet = Worksheets.Add
            NewSheet.Name = el
            i = 0: ReDim b(1 To .Item(el).Count, 1 To 3)
            For Each col In .Item(el)
                i = i + 1: For x = 1 To 3: b(i, x) = a(col, x): Next
            Next
            NewSheet.[a1].Resize(UBound(b), 3) = b
        Next
 
    End With
End Sub

            With NewSheet
                .[a1].Resize(UBound(b), 3) = b
                .Range("A:C").Sort Key1:=.Range("C1"), Order1:=xlAscending, Header:= _
                                   xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                                   DataOption1:=xlSortTextAsNumbers
            End With