Sub Razdel_FIO()
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
Dim arr
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   For i = iLastRow To 1 Step -1
     If InStr(1, Cells(i, "D"), Chr(10)) <> 0 Then
       arr = Split(Cells(i, "D"), Chr(10))
       For n = UBound(arr) To 0 Step -1
         If arr(n) <> "" Then
           Rows(i + 1).Insert
           Cells(i + 1, "D") = arr(n)
           Range("A" & i & ":C" & i).Copy Range("A" & i + 1)
         End If
       Next
         Rows(i).Delete
     End If
   Next
End Sub