【VBA】シートから他シートに振分けコピー、シート名にセルの名称をつける

Sub シートへ振分け()
Dim i As Long
Range("A:A").Copy Range("Q1")
Range("Q1").CurrentRegion.RemoveDuplicates 1, xlYes 'A列の重複なしリストをQ列に作成
With Sheets("Sheet1") 'シート1を選択
For i = 2 To Cells(Rows.Count, 17).End(xlUp).Row '2行目から最終行まで17列目まで
.Range("A1").AutoFilter 1, .Cells(i, 17) '
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = .Cells(i, 17)
.Range("A1").CurrentRegion.Copy Range("A1")
Next i
End With
End Sub