Creating sheets with names in column B and assigning data to each sheet for particular name

Question

I want to create a sheet for each distinct name and copy and paste the data for that person to that sheet. I have a workbook with a master sheet in which I have assigned data to a group of persons. I created a code, however the problem is that it creates just one sheet with a list of first names and repeatedly copies each row into cell A1:H1. not changing the sheet's name or relocating to A2:H2.

Expected result

Sub CreateSheetsForNames()

Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim sht As Worksheet

Set ws = ThisWorkbook.Sheets("SM")
Set rng = ws.Range("B2", ws.Range("B" & Rows.Count).End(xlUp))

For Each cell In rng
    If Len(cell.Value) > 0 And Not IsNumeric(cell.Value) Then
        On Error Resume Next
        Set sht = ThisWorkbook.Sheets(cell.Value)
        On Error GoTo 0
        If sht Is Nothing Then
            Set sht = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            sht.Name = cell.Value
        End If
        ws.Range("A" & cell.Row & ":H" & cell.Row).Copy sht.Range("A1")
    End If
Next cell

End Sub

Answer 1

after the first occurrence of Set sht = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)), sht will NOT be Nothing even if Set sht = ThisWorkbook.Sheets(cell.Value) should fail

so be sure to set sht to Nothing at each iteration

while ... .Copy sht.Range("A1") will always be pasting from cell A1 of the target sheet, hence you have to update the target cell like with sht.Cells(Rows.Count, 1).End(xlUp).Offset(1)

So that you could use the following:

For Each cell In rng
    If Len(cell.Value) > 0 And Not IsNumeric(cell.Value) Then
        Set sht = Nothing ' set sht to Nothing and erase the result of the preceeding loop
        On Error Resume Next
        Set sht = ThisWorkbook.Sheets(cell.Value)
        On Error GoTo 0
        If sht Is Nothing Then
            Set sht = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            sht.Name = cell.Value
        End If
        ws.Range("A" & cell.Row & ":H" & cell.Row).Copy sht.Cells(Rows.Count, 1).End(xlUp).Offset(1) 'paste starting from column A first empty cell after last not empty one
    End If
Next cell