поиск в TXT по слову и перенос в Excel по столбцам через табуляцию

[Mkoty]

Добрый День.
Существует ТХТ в котором 10 столбцов разделенных символами табуляции.
Требуется:
Выбрать строки в которых найдено значение и вставить в Эксель.
но заносило по столбцам через табуляцию.
сделал, но по столбцам не заносит:

Sub test()     '
    strFilePath = "MyTestFile.txt"
    Call ImportFromTxt("\\Servbuh\e\Аналитика\Текст.txt", "*02805*")
End Sub
 
Sub ImportFromTxt(ByVal strFilePath As String, ByVal strLike As String)
  Const ForReading As Byte = 1
  
  Dim i As Long
  Dim fso As Object, tso As Object
  Dim strLine As String
  Dim x As Long: x = 1
 
  Set fso = CreateObject("Scripting.FileSystemObject")      '
  Set tso = fso.OpenTextFile(strFilePath, ForReading)
 
  i = 1
  Sheets("Лист2").Select
  Cells.Select
  Application.CutCopyMode = False
  Selection.ClearContents
  
  Do While Not tso.AtEndOfStream        '
        strLine = tso.ReadLine
        If strLine Like strLike Then
            Cells(x, 1).Value = strLine
            x = x + 1
        End If
    i = i + 1
  Loop
 
  tso.Close
  Set tso = Nothing
 
  Set fso = Nothing
End Sub

есть другой макрос заносит по столбцам, но все подряд.

Sub tt()
Dim a, i&, tmp
a = Split(CreateObject("Scripting.FileSystemObject").Getfile("\\Servbuh\e\Аналитика\Текст.txt").OpenasTextStream(1).readall, vbNewLine)
For i = 0 To UBound(a)
a(i) = Replace(a(i), """", "")
tmp = Split(a(i), vbTab)
Cells(i + 1, 1).Resize(1, UBound(tmp)) = tmp
Next
End Sub

скрестить их не могу
если не сложно помогите

[Aleksandr H.]

Option Explicit

Sub test()     '
    Dim strFilePath As String
    strFilePath = Environ("USERPROFILE") & "\Desktop\Текст.txt"
    Call ImportFromTxt(strFilePath, "*02805*")
End Sub

Sub ImportFromTxt(ByVal strFilePath As String, ByVal strLike As String)
    Const ForReading As Byte = 1
    
    Dim i As Long
    Dim tmp
    Dim fso As Object, tso As Object
    Dim strLine As String
    Dim x As Long: x = 1
    
    Set fso = CreateObject("Scripting.FileSystemObject")      '
    Set tso = fso.OpenTextFile(strFilePath, ForReading)
    
    i = 1
    Sheets("Лист2").Select
    Cells.Select
    Application.CutCopyMode = False
    Selection.ClearContents
    
    Do While Not tso.AtEndOfStream        '
        strLine = tso.ReadLine
        If strLine Like strLike Then
            tmp = Split(strLine, vbTab)
            Cells(x, 1).Resize(1, UBound(tmp)) = tmp
            x = x + 1
        End If
        i = i + 1
    Loop
    
    tso.Close
    Set tso = Nothing
    
    Set fso = Nothing
End Sub

[Mkoty]

Спасибо огромное.
Работает!

Только последний столбец не заносит

разобрался, после последнего значения в столбце поставил табуляцию и жизнь наладилась