Maybe:
Sub rxg2669()
Dim i As Long
Dim ws As Worksheet
Set ws = ActiveSheet
Sheets.Add.Name = "Name Count"
ws.Activate
For i = Range("A" & Rows.Count).End(3).Row To 2 Step -1
If Range("A" & i).Value <> Range("A" & i + 1).Value Then
Sheets("Name Count").Range("A" & Rows.Count).End(3)(2) = Range("A" & i).Value
Rows(i + 1).Insert
End If
Next i
Range("B2").Select
zz:
If ActiveCell.Offset(2) = "" Then
ws.Range("A2:A" & ws.Range("A" & Rows.Count).End(3).Row).SpecialCells(4).EntireRow.Delete
Exit Sub
End If
x = 0
Do Until ActiveCell.Value = ""
If Cells(ActiveCell.Row, "B") <> Cells(ActiveCell.Row + 1, "B") Then x = x + 1
ActiveCell.Offset(1).Select
Loop
Sheets("Name Count").Range("B" & Rows.Count).End(3)(2) = x
If ActiveCell.Value = "" And ActiveCell.Offset(1) <> "" Then ActiveCell.Offset(1).Select
GoTo zz
End Sub
Bookmarks