Do you want a sheet for each name
Option Explicit
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
Sub moveRow()
Dim aWs As Worksheet
Dim rng As Range
Dim cl As Range
Dim sShtNm As String
Set aWs = Sheets("Sheet1")
With aWs
Set rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
For Each cl In rng
sShtNm = cl.Value
If Not WksExists(sShtNm) Then
Sheets.Add
ActiveSheet.Name = sShtNm
cl.EntireRow.Copy Sheets(sShtNm).Cells(1, 1)
End If
Next cl
End With
End Sub
Bookmarks