Подскажите пжлста!!

Весь MS Office, программирование на Visual Basic for Applications и MS VB

Модератор: Naeel Maqsudov

Ответить
Vaseninbox
Сообщения: 34
Зарегистрирован: 05 сен 2008, 15:11
Контактная информация:

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

Есть файл, сохранённый в режиме .txt (блокнот) в папке “Test” на рабочем столе. В нём три столбца и в каждом по 10 строк:
Например:
[HTML]18:00:53 Имя1 15663
18:00:55 Имя2 35615
18:00:59 Имя3 96451
И т.д. до десятой строки...[/HTML]

Как открыть (прочитать) этот файл макросом Excel и скопировать на «Лист1» «Книги1.xls» эти три столбца соответственно в A1:A10-для первого, B1:B10-для второго и в C1:C10-для третьего столбца из документа .txt??
Аватара пользователя
EducatedFool
Сообщения: 197
Зарегистрирован: 06 апр 2008, 14:03
Откуда: Россия, Урал
Контактная информация:

Код: Выделить всё

Sub test()
    Application.ScreenUpdating = False
    Filename = "C:\Documents and Settings\Администратор\Рабочий стол\Текст.txt"    ' укажите здесь полный путь к своему текстовому файлу

    Workbooks.OpenText Filename:=Filename, DataType:=xlDelimited, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, Space:=True
    If ActiveWorkbook.FullName = Filename Then    ' файл открылся
        ActiveSheet.UsedRange.Copy ThisWorkbook.Worksheets(1).[a1]    ' копируем содержимое текстового файла в этот файл
        ActiveWorkbook.Close False    ' закрываем текстовый файл без сохранения
    End If
End Sub
Аватара пользователя
EducatedFool
Сообщения: 197
Зарегистрирован: 06 апр 2008, 14:03
Откуда: Россия, Урал
Контактная информация:

А такой код будет работать ещё быстрее:

Код: Выделить всё

Sub test2()
    On Error Resume Next
    Filename = "C:\Documents and Settings\Администратор\Рабочий стол\Текст.txt"    ' укажите здесь полный путь к своему текстовому файлу

    Dim arr()    ', fso As FileSystemObject, ts As TextStream
    Set fso = CreateObject("scripting.filesystemobject"): Set ts = fso.OpenTextFile(Filename, 1)
    If ts Is Nothing Then Exit Sub
    content = ts.ReadAll: ts.Close

    While InStr(1, content, "  ") > 0: content = Replace(content, "  ", " "): Wend
    a = Split(content, vbCrLf): If Not IsArray(a) Then Exit Sub
    b = Split(a(1), " "): If Not IsArray(b) Then Exit Sub

    ReDim arr(0 To UBound(a), 0 To UBound(b))
    For i = 0 To UBound(a): b = Split(a(i), " "): For j = 0 To UBound(b): arr(i, j) = b(j): Next: Next

    ThisWorkbook.Worksheets(1).Range("a1").Resize(UBound(a) + 1, UBound(b) + 1).Value = arr
End Sub
Аватара пользователя
Aent
Сообщения: 1129
Зарегистрирован: 01 окт 2006, 14:52
Откуда: Saratov,Russia
Контактная информация:

А ещё быстрее будет не использовать FSO а обойтись средствами VBA, который сам успешно умеет читать файлы :)
Более того, если колонки фиксированы, то можно не заморачиваться со Split, а использовать
старый добрый Mid$ :)
Я как то таким манером загружал в 2007 Excel логи телефонной станции.
900000 записейзагрузилось за несколько секунд :) :)
Для 10 строк всё это конечно никакого значения не имеет ...
Андрей Энтелис,
aentelis.livejournal.com
Аватара пользователя
Naeel Maqsudov
Сообщения: 2570
Зарегистрирован: 20 фев 2004, 19:17
Откуда: Moscow, Russia
Контактная информация:

:) ну вы даете, господа! Браво.
Я вчера написал другой вариант. Закину... Не пропадать же добру :)
Я воспользовался методом TextToColumn (который стандартно вызывается из меню Данные\Текст по столбцам)

Код: Выделить всё

Sub test()
  Call Read_N_Split(Range("B3"), "C:\somefile.txt")
End Sub

Sub Read_N_Split(base As Range, file As String)
  Dim i As Integer, FN As Integer
  FN = FreeFile
  Open file For Input As #FN
  i = -1
  
  While Not EOF(FN)
    Input #FN, S
    If Trim(S) > "" Then
      i = i + 1
      base.Offset(i, 0).Value = S
    End If
  Wend
  Close #FN
  
  base.Range(Cells(1, 1), Cells(i + 1, 1)).TextToColumns Destination:=base, _
  DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
  ConsecutiveDelimiter:=True, Space:=True, _
  FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1))
  
End Sub

Ответить