Sub Run()
  Dim EndRow As Integer
  Dim CurRow As Integer
  Dim FamName As String
  Dim CurName As String
  
  CurRow = 2
  EndRow = 10000

With ThisWorkbook.ActiveSheet
  EndRow = .Cells(EndRow, 2).End(xlUp).Row
    Do While .Cells(CurRow, 2) <> ""
      CurName = .Cells(CurRow, 2)
      CurName = Left(CurName, InStr(1, CurName, " ") - 1)
        If FamName <> CurName Then FamName = CurName: .Rows(CurRow).Insert Shift:=xlDown
    CurRow = CurRow + 1
    Loop
End With
End Sub