Страницы: 1
RSS
Экспорт из Word, не открывая файл
 
Добрый день.
Мне нужно экспортировать данные из файлов doc в табличку excel. Я написал макрос, который по очереди открывает файлы doc, копирует оттуда все содержимое на лист таблицы, закрывает файл doc и обрабатывает скопированное. Таким образом, на один файл уходит около 10 секунд. И все бы хорошо, но файлов у меня 40000. По прикидкам обработка всего массива займет около недели)

Как я заметил, основное время тратится именно на открытие и закрытие файла. Вопрос: можно ли скопировать содержимое файла, не открывая его?
 
Вообще экспорт производит тот, кто экспортирует.
А импорт - тот кто импортирует.
Поэтому не может быть
Цитата
Экспорт из Word, не открывая файл
:)
А по задаче - если это именно doc, то попробуйте не открывать приложение Ворд на каждом файле, открывайте файлы в уже с начала процесса открытом Ворде.
 
Цитата
Hugo написал:
Вообще экспорт производит тот, кто экспортирует.А импорт - тот кто импортирует
Ну конечно импорт, после рабочего дня уже не чувствуешь разницы))

Т.е. после каждого файла закрывать не все приложение Word, а только файл? Спасибо, попробую. А способа вообще без открытия нет?
 
Да, закрывать только файлы, приложение закрывать только в самом конце - так не будете тратить время на многократное открытие Ворда.
Как читать doc без Ворда - не знаю, думаю полноценно никак.
 
Цитата
Hugo написал:
Как читать doc без Ворда - не знаю, думаю полноценно никак.
А нужно ли полноценно?
Вот пример прочтения файла d.doc без использования word (в скриншоте).
Командой k:\CatDoc>catdoc d.doc >ds.txt можно кинуть содержимое doc в txt файл.
Конечно, форматирование потеряется, но может оно и не нужно.
Были бы примеры, можно было бы подумать.
 
К сожалению, информация закрытая, поэтому без примеров. Но описать могу. Вордовские файлы по сути состоят из табличек, с помощью которых сделан аналог рамки ЕСКД. Поэтому при копировании в excel сохраняется правильная разбивка на ячейки, и я могу правильно распарсить полученные данные,чтобы провести с ними работу. Поэтому непонятно, как скопируется в txt, буду проверять.
 
Попробовал - на выходе пустой текст.
 
Ссылка на утилиту catdoc на сайте разработчика
На 64-битной ОС не запустилась.
Извлекает текст документа doc (не docx !) в окно командной строки. Положить файл.doc в папку с утилитой (чтобы не заморачиваться с путями).
Ввести команду catdoc файл.doc
В результате в окне командной строки появится текст из файла файл.doc
Командой catdoc файл.doc >out.txt можно кинуть содержимое doc в txt файл.
К сожалению, таблицы не распознаёт, поэтому для ТС, возможно, это направление будет неприемлемо.

Цитата
Amberalex написал:
поэтому без примеров
Можно же сделать примеры вручную с похожей структурой файла и приложить пример кода, как Вы собираете информацию с файлов в течение 10 секунд. Возможно, здесь Вам подскажут более оптимальное решение, о котором Вы не подозреваете.

Проблема интересна тем, что часто возникает необходимость найти в папке среди сотен и даже тысяч документов документ с нужным текстом, если имя файла с нужным содержимым неизвестно. Как-то ведь справляются с поиском Total Commander и другие программы.
 
Цитата
Amberalex написал:
скопировать содержимое файла, не открывая его?
изначально это утопия. Невозможно заглянуть внутрь чего-то, не открыв.
Если хотите именно побыстрее чтобы работало - хотя бы код макроса по копированию приложите. Иначе советовать-то нечего. Как вариант - если это файлы 2007 офиса(т.е. docx и им подобные), то можно при наличии навыков открывать через архив и извлекать содержимое в структуре XML. По времени будет быстрее, скорее всего, но вот сколько придется потратить, чтобы разобраться со всеми хитросплетениями внутри самого XML - большой вопрос.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Цитата
aequit написал:
Проблема интересна
Учитывая, что проблема интересна, всё-таки сделал образец файла
Код
Option Explicit
Const RowStart = 3
Const ColStart = 2

Dim objFSO As Object, objFolder As Object, objFile As Object

Sub workfile(filePath As String)
Dim wtemp As Worksheet
Dim wdb As Worksheet
Dim marsh As String
Dim tempstring As String, tempotdel As String, tempoper As String, tempcaption As String
Dim i As Integer
Dim startCell As Range

    Application.ScreenUpdating = False

    Set wtemp = Worksheets("Temp")
    Set wdb = Worksheets("БД")

    Worksheets("Temp").Cells.Clear
    
    On Error Resume Next

        loadfile (filePath)
        
        Set startCell = Worksheets("Temp").Cells.Find(What:="ЯкорьМакроса", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False)
        
        If InStr(startCell.Offset(0, 1), "(") <> 0 Then
            wdb.Cells(RowStart + Range("TPCount"), ColStart + 1) = myTrim(Left(startCell.Offset(0, 1), InStr(startCell.Offset(0, 1), "(") - 1)) & ";" & myTrim(Mid(startCell.Offset(0, 1), InStr(startCell.Offset(0, 1), "(")))
        Else
            wdb.Cells(RowStart + Range("TPCount"), ColStart + 1) = myTrim(startCell.Offset(0, 1))
        End If
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 2) = myTrim(startCell.Offset(1, 1))
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 3) = myTrim(startCell.Offset(2, 1))
        If InStr(startCell.Offset(3, 1), "+") Then
            wdb.Cells(RowStart + Range("TPCount"), ColStart + 4) = myTrim(Left(startCell.Offset(3, 1), InStr(startCell.Offset(3, 1), "+") - 1)) & ";" & myTrim(Mid(startCell.Offset(3, 1), InStr(startCell.Offset(3, 1), "+")))
        Else
            wdb.Cells(RowStart + Range("TPCount"), ColStart + 4) = myTrim(startCell.Offset(3, 1))
        End If
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 5) = myTrim(startCell.Offset(4, 1))
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 6) = myTrim(startCell.Offset(5, 1))
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 7) = myTrim(startCell.Offset(6, 1))
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 8) = myTrim(startCell.Offset(7, 1))
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 10) = filePath
        
        marsh = ""
        tempstring = ""
        tempotdel = ""
        tempoper = ""
        tempcaption = ""
        
        Set startCell = Worksheets("Temp").Cells.Find(What:="Якорь2", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Offset(-2, 0)
        
        For i = 3 To 303
            If (startCell.Offset(i, 0) = "Ошибка") Then
                Exit For
            End If
            If (startCell.Offset(i, 1)) <> "" Then
                If tempoper <> "" Then
                    tempstring = tempotdel & "$" & tempoper & "$" & tempcaption & "@"
                    marsh = marsh & tempstring
                End If
                tempstring = ""
                tempotdel = myTrim(startCell.Offset(i, 0))
                tempoper = Format(CInt(startCell.Offset(i, 1)), "000")
                tempcaption = myTrim(startCell.Offset(i, 2))
            Else
                If (startCell.Offset(i, 0) <> "") Then
                    tempotdel = tempotdel & ";" & myTrim(startCell.Offset(i, 0))
                End If
                If (startCell.Offset(i, 2) <> "") Then
                    tempcaption = tempcaption & " " & myTrim(startCell.Offset(i, 2))
                End If
            End If
        Next i
        marsh = marsh & tempotdel & "$" & tempoper & "$" & tempcaption & "@"
        wdb.Cells(RowStart + Range("TPCount"), ColStart + 9) = marsh
        wdb.Cells(RowStart + Range("TPCount"), ColStart) = Range("TPCount") + 1

    
    wdb.Activate
    
    On Error GoTo 0
    
    Application.ScreenUpdating = True
    
End Sub

Sub loadfile(filePath As String)
Dim RngCopy
Dim oWordApl As Object
Dim oDocument As Object

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error Resume Next

    Set oWordApl = CreateObject("word.application")
    Set oDocument = oWordApl.Documents.Open(filePath)
    oWordApl.Visible = True
    
     With oWordApl.ActiveDocument
        Set RngCopy = .Range(0, .Characters.Count)
        RngCopy.Select
        oWordApl.Selection.Copy
    End With

    With Worksheets("Temp")
        .Select
        .Range("A1").Select
        .Paste
    End With
    
    oWordApl.ActiveDocument.Close
    oWordApl.Visible = False
    oWordApl.Quit
    Set RngCopy = Nothing
    Set oDocument = Nothing
    Set oWordApl = Nothing
    
    On Error GoTo 0
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Sub Get_All_File_from_SubFolders()
Dim sFolder As String

    sFolder = chooseFolder
    
    If sFolder <> "" Then
    
         sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    
            Application.ScreenUpdating = False
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            GetSubFolders sFolder
            Set objFolder = Nothing
            Set objFSO = Nothing
            Application.ScreenUpdating = True
    
    End If
      
End Sub

Private Sub GetSubFolders(sPath)
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        workfile (objFile.path)
        ThisWorkbook.Save
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.path & Application.PathSeparator
    Next
End Sub

Function chooseFolder()
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Dim path As String
 
 Set fd = Application.FileDialog(msoFileDialogFolderPicker)
 With fd
    .ButtonName = "Выбрать"
    If .Show = -1 Then
        For Each vrtSelectedItem In .SelectedItems
            path = vrtSelectedItem
        Next vrtSelectedItem
    Else
        Exit Function
    End If
 End With
 Set fd = Nothing
 
 If path <> "" Then
    chooseFolder = path
 Else
    chooseFolder = ""
 End If
End Function

Function myTrim(text As String) As String
  text = Trim(text)
    Do While InStr(text, "  ")
      text = Replace(text, "  ", " ")
    Loop
  myTrim = text
End Function

Sub aloneFile()
Dim filePath As String

    filePath = Application.GetOpenFilename
    If filePath <> "" Then
        workfile (filePath)
    End If
End Sub
Файл excel не влез по размеру, выкладываю код.
.
Изменено: Amberalex - 14.02.2020 12:55:11
 
Цитата
Amberalex написал:
If .Show = -1 Then
       For Each vrtSelectedItem In .SelectedItems
           path = vrtSelectedItem
       Next vrtSelectedItem
  Else
       Exit Function
  End If
или я чего-то сильно не понимаю, или цикл здесь очень лишний. Вы же вызываете диалог выбора ПАПКИ. А более двух выбрать все равно нельзя. Следовательно достаточно этого:
Код
If .Show = -1 Then
        path = .SelectedItems(1)
Else
        Exit Function
End If
Цитата
Amberalex написал:
With oWordApl.ActiveDocument
       Set RngCopy = .Range(0, .Characters.Count)
       RngCopy.Select
       oWordApl.Selection.Copy
   End With

   With Worksheets("Temp")
       .Select
       .Range("A1").Select
       .Paste
   End With
вот это можно записать еще так:
Код
oWordApl.ActiveDocument.Range().Copy
Worksheets("Temp").Range("A1").PasteSpecial xlPasteAll
Изменено: Дмитрий(The_Prist) Щербаков - 14.02.2020 13:31:17
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Цитата
Amberalex написал:
Файл excel не влез по размеру, выкладываю код.
Можно ведь сжать (или на облако и сюда ссылку)...
На первый быстрый взгляд, я бы начал со строк 95, 96, 103, 105, 121, 124
Зачем Вам каждый открываемый документ делать видимым? oWordApl.Visible = True Почему?
Лучше применить раннее связывание, не нужно выгружать приложение после обработки каждого файла и т.п.
 
Цитата
Дмитрий(The_Prist) Щербаков написал:
oWordApl.ActiveDocument.Range().CopyWorksheets("Temp").Range("A1").PasteSpecial xlPasteAll
Вот это не стало работать, данные где-то по пути теряются.

За остальное спасибо, переделал так, чтобы Ворд открывался только один раз - на тестовых 25 файлах уменьшение времени обработки составило 65%.
 
Цитата
Amberalex написал:
это не стало работать
да, это я ступил. Забыл, что при таком подходе Word в Excel вставиться картинкой. Но копировать диапазон можно так, как показал - без отсчета символов.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Страницы: 1
Наверх