Sub Digit16()
Dim i As Long
Dim j As Integer
Dim n As Long
Dim iLastRow As Long
Dim MyArr
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   n = 1
   Sheets("Лист2").Cells.ClearContents
   For i = 1 To iLastRow
    If Cells(i, 1) <> "НЕТ" Then
      MyArr = Split(Cells(i, 1), Chr(10))
      With Sheets("Лист2")
        For j = 0 To UBound(MyArr)
          .Cells(n, 1) = Mid(MyArr(j), 1, 16)
          n = n + 1
        Next
      End With
    End If
   Next
End Sub

Sub Нет()
Dim i&, i_n&, k&, k1&, s&
Dim tabl() As String, tabl2() As String
Dim MyArr
i_n = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim tabl(i_n)
For i = 1 To i_n
  tabl(i) = Replace(Worksheets(1).Cells(i, 1), " ", "")
Next i
For i = 1 To i_n
  If InStr(tabl(i), Chr(13)) > 0 Then
  s1 = 0
    For s = 1 To Len(tabl(i))
       If InStr(Right(tabl(i), Len(tabl(i)) - s), Chr(13)) > 0 Then
          k = k + 1
          ReDim Preserve tabl2(k)
          Slovo = Right(tabl(i), Len(tabl(i)) - s - 1)
          Slovo1 = InStr(Right(tabl(i), Len(tabl(i)) - s), Chr(13))
          tabl2(k) = Left(Right(tabl(i), Len(tabl(i)) - s1), InStr(Right(tabl(i), Len(tabl(i)) - s1), Chr(13)))
          s1 = s1 + InStr(Right(tabl(i), Len(tabl(i)) - s1), Chr(13))
          s = s1
       Else
          If s < Len(tabl(i)) Then
              k = k + 1
              ReDim Preserve tabl2(k)
              tabl2(k) = Left(Right(tabl(i), Len(tabl(i)) - s1), Len(tabl(i)))
              Exit For
          End If
       End If
    Next s
  End If
Next i
For i = 1 To k
   tabl2(i) = Replace(Replace(tabl2(i), Chr(10), ""), Chr(13), "")
   Worksheets(2).Cells(i, 1).NumberFormat = "@"
   Worksheets(2).Cells(i, 1).Value = tabl2(i)
Next i
End Sub

   Worksheets(2).Cells(i, 1).NumberFormat = "@"

Worksheets(2).Cells(i, 1).Value = "'" & tabl2(i)