End Select
    
 Range("$A$1").Select
 
    Selection.EntireColumn.Insert
    Selection.EntireColumn.Insert
    Selection.EntireColumn.Insert
    Selection.EntireColumn.Insert
    Selection.EntireColumn.Insert
    Selection.EntireColumn.Insert
    Selection.EntireColumn.Insert
       
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & mypath & f1.Name, Destination:= _

'################################################################
'скрипт рассчитан на обработку текстовых файлов из c:\temp\mytxt\
'там же должен быть Test.xls, куда будут помещаться результаты
'################################################################

Dim fso, f, f1, fc, txs
Dim mypath' As String
Dim s' As String
Dim Dt()

t = Timer
    
mypath = "c:\temp\mytxt\"
        
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(mypath)
Set fc = f.Files
	if fc.count >  0  then
		Set objfullExcel = CreateObject("Excel.Application"): Set wb = objfullExcel.Workbooks.Open (mypath & "\Test.xls", Readonly = False)
	else
		Wscript.Quit
	end if

For Each f1 In fc
If UCase(fso.GetExtensionName(f1.Path)) = "TXT" Then

    Set txs = f1.OpenAsTextStream( 1 )
    s = txs.ReadAll
    txs.Close
    s = Replace(s, vbtab, "|")  'меняем vbtab, было условие в query
	arrLineList = Split(s , vbNewLine) 'массив всех строк, начало с 0

ReDim Preserve Dt(UBound(arrLineList), 4 )'устанавливаем размерность массива по числу строк, 5 элементов в строке (так в примере)

 for y =  0  to UBound(arrLineList)
 temp = Split(arrLineList(y) , "|")
  for yy =  0  to UBound(temp)
	Dt(y,yy) = temp(yy)
  next
 next

   Select Case Right(Mid(s, InStr( 1 , s, "РД="),  5 ),  2 )
    Case "01"
	Set objExcel = wb.Worksheets( 1 ): inexcel
	Erase Dt
    Case "02"
	Set objExcel = wb.Worksheets( 2 ): inexcel
	Erase Dt
    Case "03"
	Set objExcel = wb.Worksheets( 3 ): inexcel
	Erase Dt
    Case "80"
	Set objExcel = wb.Worksheets( 4 ): inexcel
	Erase Dt
   End Select
End If	
next

objfullExcel.Visible = True

t = Timer - t
msgbox "OK! Run in " & t

Wscript.Quit

Sub inexcel()

cnt = objExcel.UsedRange.rows.count: if cnt =  1  then cnt =  0  ' для начала файла сбрасываем в 0
' есть недочёт - UsedRange должна быть с первой строки листа
' Cells.SpecialCells(xlCellTypeLastCell).Row заставить работать из стороннего скрипта не получилось

 for x =  0  to UBound(Dt)
  for y =  0  to UBound(Dt, 2 )
  if Dt(x, 1 ) = Empty then
 	objExcel.Cells(cnt +  1 , x + y +  1 ).Value = Dt(x,y) 
  Else
	objExcel.Cells(cnt + y +  1 , x +  1 ).Value = Dt(x,y)
  End if
  next
next

End Sub

'################################################################
'скрипт рассчитан на обработку текстовых файлов из c:\temp\mytxt\
'там же должен быть Test.xls, куда будут помещаться результаты
'################################################################

Dim fso, f, f1, fc, txs
Dim mypath
Dim s
Dim Dt()
Public cnt
Public x
Public xx
Public y

t = Timer
    
mypath = "c:\temp\mytxt\"
        
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(mypath)
Set fc = f.Files
	if fc.count >  0  then
		Set objfullExcel = CreateObject("Excel.Application"): Set wb = objfullExcel.Workbooks.Open (mypath & "\Test.xls", ReadOnly = False)
		Do
		if wb.Sheets.Count <  4  then wb.Sheets(wb.Sheets.Count).Select: wb.Sheets.Add
		Loop Until wb.Sheets.Count =  4 
	else
		Wscript.Quit
	end if

For Each f1 In fc
If UCase(fso.GetExtensionName(f1.Path)) = "TXT" Then

    Set txs = f1.OpenAsTextStream( 1 )
    s = txs.ReadAll
    txs.Close
    s = Replace(s, vbtab, "|")  'меняем vbtab, было условие в query
	arrLineList = Split(s , vbNewLine) 'массив всех строк, начало с 0

ReDim Preserve Dt(UBound(arrLineList), 4 )'устанавливаем размерность массива по числу строк, 5 элементов в строке (так в примере)

	Select Case Right(Mid(s, InStr( 1 , s, "РД="),  5 ),  2 )
    Case "01"
	Set objExcel = wb.Worksheets("Лист1"): inexcel
	Erase Dt
    Case "02"
	Set objExcel = wb.Worksheets("Лист2"): inexcel
	Erase Dt
    Case "03"
	Set objExcel = wb.Worksheets("Лист3"): inexcel
	Erase Dt
    Case "80"
	Set objExcel = wb.Worksheets("Лист4"): inexcel
	Erase Dt
	Case Else
	Erase Dt	
  End Select
End If	
next

objfullExcel.Visible = True

Erase arrLineList
Set fso = Nothing
Set f = Nothing
Set fc = Nothing
Set txs = Nothing
Set s = Nothing
Set objfullExcel = Nothing
Set objExcel = Nothing

t = Timer - t
msgbox "OK! Run in " & t

Wscript.Quit

Sub inexcel()

 for y =  0  to UBound(arrLineList)
 temp = Split(arrLineList(y) , "|")
  for yy =  0  to UBound(temp)
	Dt(y,yy) = temp(yy)
  next
 next

cnt = objExcel.UsedRange.Row + objExcel.UsedRange.Rows.Count 'первая строка в любом случае считается заполненной!
'её можно позже или до начала работы скрипта заполнить заглавием.

 for x =  0  to UBound(Dt)
  for y =  0  to UBound(Dt, 2 )
  if Dt(x, 1 ) = Empty Then objExcel.Cells(cnt, x + y +  1 ).Value = Dt(x,y): xx = x
  if Dt(x, 1 ) <> Empty Then putdata : Exit For 
  next
next

End Sub

Sub putdata()

for z =  0  to UBound(Dt, 2 )
objExcel.Cells(cnt, xx + z +  2 ).Value = Dt(x,z)
next
cnt = objExcel.UsedRange.Row + objExcel.UsedRange.Rows.Count

End Sub

Option Explicit
Sub Auto_Open()
If MsgBox("Update?", vbExclamation + vbOKCancel, "Warning!") = vbOK Then update 'если уровень безопасности низкий
'update 'если уровень безопасности средний
UserForm1.Show 'в форме настройки печати результатов
End Sub

Sub update()
'# определяем переменные, необязательно, но крайне желательно
Dim objFSO As Object, objDialog As Object, objTextFile As Object, strText$, strNextLine$
Dim ddd$, linecount As Long, dt As Date, versija$
Dim oms_eur_acc$, oms_usd_acc$
Dim oms_eur_res As Double, oms_eur_nres As Double, oms_eur_es As Double
Dim oms_usd_res As Double, oms_usd_nres As Double, oms_usd_es As Double
Dim intResult As Boolean
Dim oReg As Object, strKeyPath$, strValue$, strValueName$
Dim objExcel As Object

ddd = DatePart("y", Now()) 'определяем значение сегодняшнего ddd - если ddd в названии файла генерится без ведущих нулей
'ddd = Right(("00" & DatePart("y", Now())), 3) 'определяем значение сегодняшнего ddd - если ddd генерится с ведущими нулями - 3 цифры

Set objFSO = CreateObject("Scripting.FileSystemObject")
' если есть сегодняшний файл, сразу открываем его, если нет, предлагаем
' выбрать любой другой, можно отказаться и выйти из кода
If objFSO.FileExists("c:\temp\Journal_" & ddd & ".txt") Then
   Set objTextFile = objFSO.OpenTextFile("c:\temp\Journal_" & ddd & ".txt",  1 )
Else
   '# Диалог открытия файла
   Set objDialog = CreateObject("UserAccounts.CommonDialog")
   objDialog.Filter = "Journal Files|Journal_*.txt|All Files|*.*"
   objDialog.FilterIndex =  1 
   objDialog.InitialDir = "c:\temp\"
   intResult = objDialog.ShowOpen
   If intResult =  0  Then Exit Sub
   Const ForReading =  1 
   Set objTextFile = objFSO.OpenTextFile(objDialog.Filename, ForReading)
End If

'### определяем системный разделитель дробной части, это если в системе того, кто будет считать,
'    разделитель не точка, как в текстовике
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
strKeyPath = "Control Panel\International"
strValueName = "sDecimal"
oReg.GetExpandedStringValue &H80000001, strKeyPath, strValueName, strValue 'вот этот strValue нам и нужен
'###

linecount =  0 

Do Until objTextFile.AtEndOfStream 'пока не кончился файл
  strNextLine = objTextFile.Readline 'читаем посторочно
  linecount = linecount +  1  'счётчик строк
  'из первой строки файла читаем дату отчёта и версию, вместо "V.20091201" поставить текущее значение первых 10 символов строки
  If linecount =  1  Then dt = CDate(Mid(strNextLine,  68 ,  10 )): versija = Left(strNextLine,  10 ): If versija <> "V.20091201" Then MsgBox "New Version!" & vbNewLine & "Exit!!!", vbCritical: Exit Sub

  strNextLine = Replace(strNextLine, ".", strValue)  'меняем "." на системный разделитель дробной части
  
 If Left(strNextLine,  3 ) = "sum" Then Exit Do ' выход если кончилась значимая область (читаем до слова "sum", хотя можно читать
                                              ' и до конца файла, но незачем )

 Select Case Trim(Left(strNextLine,  16 ))'ищем знакомые слова, в данном случае "Test Word EUR" или "Test Word USD"
   Case "Test Word EUR"
      oms_eur_acc = Trim(Mid(strNextLine,  27 ,  13 ))' это значение суммировать не надо, и оно всегда постоянно в данной задаче
      oms_eur_res = oms_eur_res + CDbl(Trim(Mid(strNextLine,  70 ,  9 )))
      oms_eur_nres = oms_eur_nres + CDbl(Trim(Mid(strNextLine,  80 ,  9 )))
      oms_eur_es = oms_eur_es + CDbl(Trim(Mid(strNextLine,  90 ,  9 )))
   Case "Test Word USD"
      oms_usd_acc = Trim(Mid(strNextLine,  27 ,  13 ))' это значение суммировать не надо, и оно всегда постоянно в данной задаче
      oms_usd_res = oms_usd_res + CDbl(Trim(Mid(strNextLine,  70 ,  9 )))
      oms_usd_nres = oms_usd_nres + CDbl(Trim(Mid(strNextLine,  80 ,  9 )))
      oms_usd_es = oms_usd_es + CDbl(Trim(Mid(strNextLine,  90 ,  9 )))
' Таких циклов сделать столько, сколько различных значений надо найти и посчитать
 End Select
 
Loop 'читаем следующую строку

objTextFile.Close 'всё прочитано, закрываем текстовый файл

'Заносим данные в уже готовые формы
'Таких блоков сделать столько, во сколько форм надо занести значения
Set objExcel = ThisWorkbook.Sheets("TestEUR")
objExcel.Cells( 1 ,  10 ).Value = dt
objExcel.Cells( 9 ,  3 ).Value = oms_eur_acc
objExcel.Cells( 10 ,  5 ).Value = oms_eur_res
objExcel.Cells( 10 ,  11 ).Value = oms_eur_nres
objExcel.Cells( 12 ,  5 ).Value = oms_eur_es

Set objExcel = ThisWorkbook.Sheets("TestUSD")
objExcel.Cells( 1 ,  10 ).Value = dt
objExcel.Cells( 9 ,  3 ).Value = oms_usd_acc
objExcel.Cells( 10 ,  5 ).Value = oms_usd_res
objExcel.Cells( 10 ,  11 ).Value = oms_usd_nres
objExcel.Cells( 12 ,  5 ).Value = oms_usd_es


'# очищаем память, необязательно, но желательно
Set objFSO = Nothing
Set objDialog = Nothing
Set objTextFile = Nothing
strNextLine = Empty
Set objExcel = Nothing

End Sub