Sub Test()
Dim Rng As Range
Dim ShSource As Worksheet
Dim x As Long
Dim c As Range
Dim ShName As String
' *** Change name of original worksheet to suit ***
Set ShSource = Worksheets("Sheet1")
' *** Change starting row in column B to suit ***
Set Rng = ShSource.Range("B1:B" & Range("B65536").End(xlUp).Row)
x = 1
Application.ScreenUpdating = False
For Each c In Rng
If c.Offset(1, 0) <> c.Value Then
ShName = c.Text
Range(Rng.Rows(x), c.EntireRow).Copy
Worksheets.Add After:=Sheets(Sheets.Count)
With ActiveSheet
.Paste
.Name = ShName
.Range("A1").Select
End With
ShSource.Activate
x = c.Row + 1
End If
Next c
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub