Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Копирование содержимого текстовых файлов - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование содержимого текстовых файлов (Макросы/Sub)
Копирование содержимого текстовых файлов
Sashagor1982 Дата: Суббота, 27.04.2019, 23:04 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 189
Репутация: 14 ±
Замечаний: 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
 
Ответить
СообщениеДрузья. Данная программа копирует содержимое текстовых файлов из определенной папки в 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]
Вопрос в том как ее доработать, чтобы была вставка аналогична Специальная вставка - ТЕКСТ. Спасибо.

Автор - Sashagor1982
Дата добавления - 27.04.2019 в 23:04
boa Дата: Четверг, 02.05.2019, 18:45 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 378
Репутация: 102 ±
Замечаний: 0% ±

2013, 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. Исправьте название темы.




Сообщение отредактировал boa - Четверг, 02.05.2019, 18:52
 
Ответить
Сообщение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. Исправьте название темы.

Автор - boa
Дата добавления - 02.05.2019 в 18:45
RAN Дата: Четверг, 02.05.2019, 20:41 | Сообщение № 3
Группа: Друзья
Ранг: Участник клуба
Сообщений: 5055
Репутация: 1005 ±
Замечаний: 0% ±

2010
чтобы была вставка аналогична Специальная вставка - ТЕКСТ

[vba]
Код
wrdDoc.Content.Copy
[/vba]
чтобы была вставка Специальная вставка - ТЕКСТ
[vba]
Код
Sheets(wrdDoc.Name).PasteSpecial Format:="Текст", Link:=False, DisplayAsIcon:=False
[/vba]
чтобы была вставка аналогична Специальная вставка - ТЕКСТ
[vba]
Код
Sheets(wrdDoc.Name).Range("A1").PasteSpecial xlPasteValues
[/vba]


Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщение
чтобы была вставка аналогична Специальная вставка - ТЕКСТ

[vba]
Код
wrdDoc.Content.Copy
[/vba]
чтобы была вставка Специальная вставка - ТЕКСТ
[vba]
Код
Sheets(wrdDoc.Name).PasteSpecial Format:="Текст", Link:=False, DisplayAsIcon:=False
[/vba]
чтобы была вставка аналогична Специальная вставка - ТЕКСТ
[vba]
Код
Sheets(wrdDoc.Name).Range("A1").PasteSpecial xlPasteValues
[/vba]

Автор - RAN
Дата добавления - 02.05.2019 в 20:41
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование содержимого текстовых файлов (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2019 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!