Need to delete multiple lines in cells but keep one

Sub bbtest4()
Dim cell As Range
numrow = ActiveSheet.UsedRange.Rows.Count
Set Rng = ActiveSheet.Range("O7:S" & numrow)
For Each cell In Rng
  If Not IsDate(cell.Value) Then
    For i = 1 To Len(cell.Text)
        With cell.Characters(i, 1)
            If .Font.Bold Or .Font.Italic Or .Font.Strikethrough _
            Or .Font.Superscript Or .Font.Subscript Or .Font.OutlineFont _
            Or .Font.Shadow Or (.Font.Color > 1 And .Font.Color <> 255) Then
            Else
                MyText = MyText & .Text
            End If
        End With
    Next i
    cell.Value = MyText
    cell.Font.ColorIndex = 1
    cell.Font.Strikethrough = False
    Do While Left(cell.Text, 1) = vbLf
      cell.Value = Right(cell.Text, Len(cell.Text) - 1)
    Loop
    MyText = ""
  End If
Next
End Sub