特定列で、シート分け（特定の列に記入されているセル内容をシート名にする）

特定列で、シート分け（特定の列に記入されているセル内容をシート名にする）
なので、特定セルのセル内容は、順番に並んでいる必要があり、同じ名前が再び出てくるような順番になっているとエラーが発生！（同じシート名でシートを存在させることは出来ないので）

Sub シート分け_AQ列基準()

'シートが複数あると中止
Dim ShtCheck As String
ShtCheck = Sheets.Count
If ShtCheck > 1 Then
MsgBox "シートが複数あります。" & vbCrLf & "1枚のみにして再度やり直してください。" ' & vbCrLf & は改行
Exit Sub
Else
End If

'シート分け機能
Dim ShtCuti As Worksheet
Dim AreaCuti As Range
Dim NameCuti As Range
Dim RowCuti As Variant

Set ShtCuti = ActiveSheet
RowCuti = Rows(1).Value
'Application.ScreenUpdating = False

'並び替えがきれいにいくようにふりがなフリガナを削除する
Range("AQ:AQ").Characters.PhoneticCharacters = "" '■AQを設定

Range("A1").Subtotal 43, xlCount, Array(42) '■AQが43番目なので、43と42を設定

Set AreaCuti = Range("A2", Range("A1048576").End(xlUp)).SpecialCells(2)
For Each NameCuti In AreaCuti.Areas
With Worksheets.Add(After:=Worksheets(Worksheets.Count))
.Rows(1).Value = RowCuti
NameCuti.EntireRow.Copy
.Range("A2").PasteSpecial xlPasteAll
.Range("A1").Select
.Name = NameCuti.Range("AQ1").Value '■AQ1を設定
Selection.ClearOutline
End With
Application.CutCopyMode = False
Next

ShtCuti.Activate: ShtCuti.Cells.RemoveSubtotal

'Application.ScreenUpdating = True
'オブジェクトのセット解放
Set AreaCuti = Nothing: Set ShtCuti = Nothing

End Sub