Возможно ли перегнать данные из текстового файла по ячейкам в Excel?

Dim objExcel As Excel.Application
 
Set objExcel = New Excel.Application
objExcel.Workbooks.Add ('...Путь к файлу')
 
'открывайте Ваш файл
 
'Обьеденяйте в масив
VarFull = Split(ret, '~')
    cnt = UBound(VarFull)
    MEdit.MousePointer = vbDefault
    For rec = 0 To cnt
    ret = VarFull(rec)
 
      With objExcel.ActiveSheet
.Cells(n, 1).value = n1 '
.Cells(n, 2).value = Piece(rc, ' ', 1)
.Cells(n, 3).value = Piece(rc, ' ', 2)
.Cells(n, 4).value = Piece(rc, ' ', 3)
. итд
 
 End With

Dim objExcel As Excel.Application
 
Set objExcel = New Excel.Application
objExcel.Workbooks.Add ('...Путь к файлу')  'здесь будете хранить данные excel
 
'открывайте Ваш файл
 
sTemp = 'D:M3   empglo.txt' 'что-то в этом роде
 FileHandle% = FreeFile
ret=''
Open sTemp For Input As #FileHandle%
While Not EOF(1)
Line Input #FileHandle%, emp
If InStr(emp, '~') Then
ret=ret  & emp
 
      End If
    Wend
    Close #1
 
'Обьеденяйте в масив 
 
VarFull = Split(ret, '~')
cnt = UBound(VarFull)
For rec = 0 To cnt
ret = VarFull(rec)
 
'Распределяй в Excel:
for n=0 to cnt
With objExcel.ActiveSheet
 .Cells(n, 2).value = Piece(ret, '~', 1)
 .Cells(n, 3).value = Piece(rc, '~', 2)
 .Cells(n, 4).value = Piece(rc, '~', 3)
. итд
 
End With
 next n

Sub sExcel(FilePath As String)
'открываем файл txt
Set fso = New Scripting.FileSystemObject
Set txtStream = fso.OpenTextFile(FilePath, ForReading)
'создаём лист Excel
Set objExcel = New Excel.Application 
Excel.Application
objExcel.Visible = True 
objExcel.SheetsInNewWorkbook = 1
objExcel.Workbooks.Add
'читаем данные из txt файла и заносим в Excel
i = 1
j = 1
While Not txtStream.AtEndOfStream
    txtLine = txtStream.ReadLine
    If IsNumeric(Mid(txtLine, 4)) = True Then
        i = 1
        j = j + 1
    End If
    objExcel.ActiveSheet.Cells(j, i) = Mid(txtLine, 4)
    i = i + 1
Wend
End Sub

Dim objExcel As Excel.Application
 
Set objExcel = New Excel.Application
objExcel.Workbooks.Add ('...Путь к файлу') 'здесь будете хранить данные excel
 
'открывайте Ваш файл
 
sTemp = 'D:M3   empglo.txt' 'что-то в этом роде
FileHandle% = FreeFile
ret=''
Open sTemp For Input As #FileHandle%
While Not EOF(1)
Line Input #FileHandle%, emp
If InStr(emp, '~') Then
ret=ret & emp
 
End If
Wend
Close #1
 
'Обьеденяйте в масив 
 
VarFull = Split(ret, '~')
cnt = UBound(VarFull)
For rec = 0 To cnt
ret = VarFull(rec)
 
'Распределяй в Excel:
for n=0 to cnt
With objExcel.ActiveSheet
.Cells(n, 2).value = Piece(ret, '~', 1)
.Cells(n, 3).value = Piece(rc, '~', 2)
.Cells(n, 4).value = Piece(rc, '~', 3)

Function Piece(chars As String, delimiter As String, position As Long)
   
    If position < 1 Then
        Piece = ''
        Exit Function
    End If
    ReDim Where(0 To position + 1) As Long
    Where(0) = 1
    Current = 1
    Length = Len(delimiter)
    For Count = 1 To position
        Where(Count) = InStr(Current, chars, delimiter)
        If Where(Count) = 0 Then Where(Count) = Len(chars) + 1
        Current = Where(Count) + Len(delimiter)
    Next Count
    If position = 1 Then
        Length = 0
    End If
    If (Where(position) = Where(position - 1)) Then
        back = ''
    Else
        back = Mid(chars, (Where(position - 1) + Length), (Where(position) - Where(position - 1) - Length))
    End If
    Piece = back
End Function

Sub bas()
Function Piece(chars As String, delimiter As String, position As Long)
 
If position < 1 Then
Piece = ''
Exit Function
End If
ReDim Where(0 To position + 1) As Long
Where(0) = 1
Current = 1
Length = Len(delimiter)
For Count = 1 To position
Where(Count) = InStr(Current, chars, delimiter)
If Where(Count) = 0 Then Where(Count) = Len(chars) + 1
Current = Where(Count) + Len(delimiter)
Next Count
If position = 1 Then
Length = 0
End If
If (Where(position) = Where(position - 1)) Then
back = ''
Else
back = Mid(chars, (Where(position - 1) + Length), (Where(position) - Where(position - 1) - Length))
End If
Piece = back
End Function
For rec = 0 To cnt
ret = VarFull(rec)
Next rec
End Function
 
Dim objExcel As Excel.Application
 
Set objExcel = New Excel.Application
objExcel.Workbooks.Add ('d:ase') 
 
sTemp = 'F:data
ewbase.txt' FileHandle% = FreeFile
ret = ''
Open sTemp For Input As #FileHandle%
While Not EOF(1)
Line Input #FileHandle%, emp
If InStr(emp, '~') Then
ret = ret & emp
 
End If
Wend
Close #1
 
VarFull = Split(ret, '~')
cnt = UBound(VarFull)
For rec = 0 To cnt
ret = VarFull(rec)
 
For n = 0 To cnt
With objExcel.ActiveSheet
.Cells(n, 2).Value = Piece(ret, '~', 1)
.Cells(n, 3).Value = Piece(rc, '~', 2)
.Cells(n, 4).Value = Piece(rc, '~', 3)
 
End With
Next n
End Function

Private Sub Command1_Click()
Dim ret As String
Dim n as integer
 
Dim objExcel As Excel.Application
Set objExcel = New Excel.Application
objExcel.Workbooks.Add ('C: est.xls') 'excel
sTemp = 'C: est.txt' 'text
FileHandle% = FreeFile
ret = ''
Open sTemp For Input As #FileHandle%
While Not EOF(1)
Line Input #FileHandle%, emp
If InStr(emp, '~') Then
ret = ret & emp
End If
Wend
Close #1
 
n = 0
VarFull = Split(ret, '~')
cnt = UBound(VarFull)
For rec = 0 To cnt
n = n + 1
ret = VarFull(rec)
 
With objExcel.ActiveSheet
objExcel.Cells(n, 1) = ret
End With
Next rec
objExcel.Visible = True
 
'Set objExcel = Nothing
End Sub

Sub sExcel(FilePath As String)
''открываем файл txt
Set fso = New Scripting.FileSystemObject
Set txtStream = fso.OpenTextFile(FilePath, ForReading)
''создаём лист Excel
Set objExcel = New Excel.Application
Excel.Application
objExcel.Visible = True
objExcel.SheetsInNewWorkbook = 1
objExcel.Workbooks.Add
''читаем данные из txt файла и заносим в Excel
i = 1
j = 1
While Not txtStream.AtEndOfStream
txtLine = txtStream.ReadLine
''Тут мы сталкиваемся с пунктом 2.
If IsNumeric(Mid(txtLine, 4)) = True Then

Dim fso As Scripting.FileSystemObject
Dim txtStream As TextStream
Private Type tField
    id As Long
    value As String
End Type
Sub sExcel(FilePath As String)
Dim txtLine As String
Dim fValue As tField
 
Set fso = New Scripting.FileSystemObject
Set txtStream = fso.OpenTextFile(FilePath, ForReading)
Set objExcel = New Excel.Application ''ñîçäàåì ýêçåìïëÿð îáúåêòà Excel.Application
objExcel.Visible = True ''äåëàåì åãî âèäèìûì (îòêðûâàåì Excel)
objExcel.SheetsInNewWorkbook = 1 ''óñòàíàâëèâàåì êîëè÷åñòâî ëèñòîâ â îòêðûâàåìîé êíèãå
objExcel.Workbooks.Add
 
j = 1
While Not txtStream.AtEndOfStream
    txtLine = txtStream.ReadLine
    If IsNumeric(Mid(txtLine, 3)) = True Then j = j + 1
    fValue = fCheckField(txtLine)
    objExcel.ActiveSheet.Cells(j, fValue.id + 1) = fValue.value
Wend
 
End Sub
Private Function fCheckField(value As String) As tField
Dim v As String
If IsNumeric(Mid(value, 3)) = True Then
    fCheckField.id = 0
    fCheckField.value = Mid(value, 3)
ElseIf IsNumeric(Mid(value, 3, 6)) = True And InStr(1, value, "@") = 0 Then
    fCheckField.id = 2
    fCheckField.value = Mid(value, 3)
Else
    v = Mid(value, 3)
    While IsNumeric(v) = False
        v = Left(v, Len(v) - 1)
    Wend
    fCheckField.id = CLng(v)
    fCheckField.value = Mid(value, 3 + Len(v))
End If
    
End Function

Sub txtExcel()
Dim TS As TextStream, FSO As Scripting.FileSystemObject
Dim Rw As Long, Cl As Long, x As Integer, y As Integer
Set FSO = New Scripting.FileSystemObject
Set TS = FSO.OpenTextFile("c:123.txt", ForReading)
Rw = 1
Do
    txtLine = TS.ReadLine
    DoEvents
    If Left(Replace(txtLine, " ", ""), 2) = "~0" Then
        Rw = Rw + 1
        Cl = 1
    Else
        Cl = Cl + 1
        If Cl > 2 And Left(Trim(Mid(txtLine, 2)), 1) = 1 Then
            x = Val(Left(Trim(Mid(txtLine, 2)), 2))
            y = InStr(1, txtLine, CStr(x)) + 2
        Else
            x = Val(Left(Trim(Mid(txtLine, 2)), 1))
            y = InStr(1, txtLine, CStr(x)) + 1
        End If
        ActiveSheet.Cells(Rw, x) = Mid(txtLine, y)
    End If
Loop While Not TS.AtEndOfStream
TS.Close
Set TS = Nothing
Set FSO = Nothing
MsgBox "Все готово"
End Sub