Sub NamesToRows()
    Dim lr As Long
    Dim i As Long
    Dim arr As Variant
    
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = lr To 1 Step -1
        With Cells(i, 1)
            arr = Split(.Value, Chr(10))
            If UBound(arr) > 0 Then
                .Offset(1, 0).EntireRow.Resize(UBound(arr)).Insert
                .Resize(UBound(arr) + 1) = Application.Transpose(arr)
            End If
        End With
    Next i
End With
End Sub