If InStr(1, sStr, "РАЗДЕЛИТЕЛЬ ТЕКСТА") > 0 Then
            Do
1000
                Line Input #filenum, sStr
                i = i + 1
                If EOF(filenum) Then GoTo ExitSub
                ReDim Preserve meData(1 To i)
                meData(i) = sStr
            Loop While InStr(1, sStr, "РАЗДЕЛИТЕЛЬ ТЕКСТА") = 0
            i = 0
            ReDim meData(1 To 1)
            GoTo 1000
        End If

Sub readtxt()
    Dim FileNameTxt$: FileNameTxt = "D:\12\1.txt"
    Dim meData$(), i&, sStr$, LastRow&
    Dim filenum&: filenum = FreeFile()
    
    LastRow = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row

    Open FileNameTxt For Input As #filenum
    sStr = Input(LOF(filenum), filenum)
    Close #filenum
    i = InStrRev(sStr, "РАЗДЕЛИТЕЛЬ ТЕКСТА")
    If i Then
      i = InStr(i, sStr, vbLf)
      If i Then
        meData = Split(Mid$(sStr, i + 1), vbCrLf)
        If UBound(meData) >= 0 Then
          Cells(LastRow + 1, 6).Resize(UBound(meData) + 1).Value = Application.Transpose(meData)
        End If
      End If
    End If

End Sub