Копирование содержимого текстовых файлов

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Копирование содержимого текстовых файлов (Макросы/Sub)

Sashagor1982

Дата: Суббота, 27.04.2019, 23:04 | Сообщение № 1

Группа: Проверенные

Ранг: Обитатель

Сообщений: 287

Репутация: -6 ±

Замечаний: 0% ±

Excel 2007

Друзья. Данная программа копирует содержимое текстовых файлов из определенной папки в EXCEL файл.
[vba]

Код

Sub Поиск()
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim FileItem As Object
    Dim objWord As Object
    Dim wrdDoc As Object
    Dim i As Long
    Dim myRange As Object
    On Error Resume Next

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.getfolder(ThisWorkbook.Path & "\11")
    Set objWord = CreateObject("Word.Application")

    For Each FileItem In SourceFolder.Files
        Set wrdDoc = objWord.Documents.Open(FileItem.Path, , True)


        Worksheets.Add.Name = wrdDoc.Name
        Sheets(wrdDoc.Name).Range("A1").Value = wrdDoc.Content
        wrdDoc.Close
    Next
    objWord.Quit
    Set wrdDoc = Nothing: Set objWord = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing

End Sub

[/vba]
Вопрос в том как ее доработать, чтобы была вставка аналогична Специальная вставка - ТЕКСТ. Спасибо.

К сообщению приложен файл: 1912384.xls (57.0 Kb)

Сообщение отредактировал Sashagor1982 - Суббота, 27.04.2019, 23:14

Ответить

boa

Дата: Четверг, 02.05.2019, 18:45 | Сообщение № 2

Группа: Друзья

Ранг: Ветеран

Сообщений: 559

Репутация: 167 ±

Замечаний: 0% ±

365

Sashagor1982,
Замените строку
[vba]

Код

Sheets(wrdDoc.Name).Range("A1").Value = wrdDoc.Content

[/vba]
строками
[vba]

Код

        s = wrdDoc.Range.Text
        arr = Split(s, vbCr)
        With Sheets(wrdDoc.Name)
            .Range(.Cells(1, 1), .Cells(UBound(arr), 1)) = Application.Transpose(arr)
        End With

[/vba]

З.Ы. и кстати, текстовые файлы - это .txt, .csv и т.п. , а вордовские файлы это уже XML. Исправьте название темы.