Namen automatisch vergeben aufgrund Tabellennamen

Sub Verteilen_auf_PL()
Dim rng1 As Range, rng2 As Range
Application.ScreenUpdating = False
With ActiveSheet.UsedRange
Set rng2 = .Cells(1, 10)
.Sort key1:=rng2, order1:=xlAscending, Header:=xlYes
Do
Set rng1 = rng2.Offset(1, 0)
If rng1.Value = "" Then Exit Do
Set rng2 = rng1.EntireColumn.Find(What:=rng1.Value, searchdirection:=xlPrevious,  _
LookAt:=xlWhole, LookIn:=xlValues)
Sheets.Add after:=Sheets(ActiveWorkbook.Sheets.Count)
ActiveSheet.Name = rng1.Value
.Rows(1).Copy ActiveSheet.Cells(1, 1)
Range(rng1, rng2).EntireRow.Copy ActiveSheet.Cells(2, 1)
Cells.Select
Cells.EntireColumn.AutoFit
Range("A2").Select
Loop
End With
Sheets(1).Select
a = MsgBox("Die Projekte wurden gefiltert und pro Projektleiter in ein separates  _
Tabellenblatt kopiert. Möchten Sie alle Tabellenblätter separat speichern?", vbYesNo, "Verteilung beendet")
If a = vbNo Then Exit 

Sub Else
For i = 1 To ActiveWorkbook.Sheets.Count
Sheets(i).Copy
ActiveWorkbook.SaveAs Sheets(1).Name
ActiveWorkbook.Close
Next
End Sub



Nun möchte ich, bevor ich die Wahl habe die Tabellenblätter als separate Dateien zu speichern, dass jeweils der Bereich A:L sämtlicher Tabellenblätter automatisch aufgrund des Tabellennamens benannt werden.

Kann mir jemand helfen, dies zu realisieren bitte?

Vielen Dank und Grüsse

Jason