Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Извлечение из doc - текста, который выделен зеленым цветом
 
Здравствуйте все.
Подскажите решение.

В папке есть три файла doc - с названиями файл1,файл2,файл3 и один файл экселя. В документе эксель - в ячейку B5 вписано название нужного вордовского файла.
Как макросом при нажатии на кнопку - вытащить из этого файла в столбец B7:B14 - построчно весь текст, который выделен зеленым цветом ?    
 
Попробуйте, ну, "ворд" не очень дружелюбны для vba ... фу ...  :)

Код
Option Explicit

Sub zelenitsa()
Dim i As Byte
Dim inipos As Long
Dim strPath As String
Dim appExl As Excel.Workbook
Dim xlsSht As Excel.Worksheet
Dim appWrd As Word.Application
Dim docWrd As Word.Document
Dim docRng As Word.Range

Const shtName As String = "List1"
'Const dostup As String = "C:\Temp\" 'Vtoroy variant

    i = 2
    strPath = ThisWorkbook.Path & "\" & Trim(Range("b5").Value) & ".doc" '"F2.doc"
    'ili
    'Vtoroy variant
    'strPath = dostup & Trim(Range("b5").Value) & ".doc" '"F2.doc"
    
    Set appExl = ThisWorkbook
    Set xlsSht = appExl.Sheets(shtName)
    Set appWrd = New Word.Application
    Set docWrd = appWrd.Documents.Open(Filename:=strPath, ReadOnly:=True)
    Set docRng = docWrd.Range
    'appWrd.Visible = True 'Tol'ko dlya testov
    
    With docRng.Find
        .Highlight = True
        .Forward = True
        
        Do While .Execute
            If docRng.HighlightColorIndex = wdBrightGreen Then
                xlsSht.Range("b" & xlsSht.Rows.Count).End(xlUp).Offset(i, 0).Value = docRng.Text
                If i = 2 Then i = 1
            End If
            inipos = docRng.End
            docRng.Start = inipos
        Loop
    End With
    
    Set docRng = Nothing
    docWrd.Close SaveChanges:=wdDoNotSaveChanges
    Set docWrd = Nothing
    appWrd.Quit
    Set appWrd = Nothing
    Set xlsSht = Nothing
    Set appExl = Nothing
End Sub
 
ocet p, скажите - а как сделать, чтобы этот макрос искал не только в F2.doc, а вообще по всем файлам doc - что лежат в одной папке со скриптом ?
 
"Скажите" или напишите ? ...  :)  ... Я бы предпочел написать, говорить слишком далеко ... голос, знаете, у меня уже не тот что раньше ...  :)  ... не долетит ...  :)
Попробуйте например:
Код
Option Explicit

Sub nayti_dokument()
Dim stlb As Integer
Dim dostup As String, docDokument As String

    Application.ScreenUpdating = False
    
    stlb = 0
    dostup = ThisWorkbook.Path & "\"
    docDokument = Dir(dostup & "F*.doc", vbNormal) 'vse dokumenty na "F", ili naprimer "*.doc" - vse dokumenty
    
    Do Until docDokument = ""
        stlb = stlb + 1
        Call zelenitsa(dostup, docDokument, stlb)
        docDokument = Dir()
    Loop
    
    Application.ScreenUpdating = True
End Sub

Sub zelenitsa(dostup As String, docDokument As String, stlb As Integer)
Dim i As Byte
Dim inipos As Long
Dim appExl As Excel.Workbook
Dim xlsSht As Excel.Worksheet
Dim appWrd As Word.Application
Dim docWrd As Word.Document
Dim docRng As Word.Range

Const shtName As String = "List1"

    i = 2
    
    Set appExl = ThisWorkbook
    Set xlsSht = appExl.Sheets(shtName)
    Set appWrd = New Word.Application
    Set docWrd = appWrd.Documents.Open(Filename:=dostup & docDokument, ReadOnly:=True)
    Set docRng = docWrd.Range
    'appWrd.Visible = True 'Tol'ko dlya testov
    
    xlsSht.Cells(5, stlb).Value = Left(docDokument, InStrRev(docDokument, ".", -1, 1) - 1)
    
    With docRng.Find
        .Highlight = True
        .Forward = True
        
        Do While .Execute
            If docRng.HighlightColorIndex = wdBrightGreen Then
                xlsSht.Cells(xlsSht.Rows.Count, stlb).End(xlUp).Offset(i, 0).Value = docRng.Text
                If i = 2 Then i = 1
            End If
            inipos = docRng.End
            docRng.Start = inipos
        Loop
    End With
    
    Set docRng = Nothing
    docWrd.Close SaveChanges:=wdDoNotSaveChanges
    Set docWrd = Nothing
    appWrd.Quit
    Set appWrd = Nothing
    Set xlsSht = Nothing
    Set appExl = Nothing
End Sub
Изменено: ocet p - 17 Апр 2018 02:03:17
 
ocet p, не работает.

Жму на кнопку - выдает ошибку: "Run-time error 432. File name or class name not found during Automation operation"
Выделяет строку  Set appWrd = New Word.Application
 
забыл вам написать что в редакторе vba надо подключить "Microsoft Word xx.x Object Library" (Tools\References)
 
ocet p, в редакторе vba - у меня уже был подключен "Microsoft Word 11.0 Object Library".

И все равно - не работало.

Выдает ошибку: "Run-time error 432. File name or class name not found during Automation operation"
Выделяет строку  Set appWrd = New Word.Application
Изменено: DJ Beast - 18 Апр 2018 03:29:03
 
аaa ... это уже странно, у меня это работает ...

... хмм ... :

1. можно бы изменить декларацию "Word.Application" на "New Word.Application" (это вторая форма раннего связывания) и тогда блокировать "Set appWrd":
Код
'Dim appWrd As Word.Application
Dim appWrd As New Word.Application

    'Set appWrd = New Word.Application
2. можно бы изменить декларацию "Word.Application" на "Object" (это форма позднего связывания) и другие части "Word" и "Set", и тогда будет как ниже:
Код
Dim appWrd As Object
Dim docWrd As Object
Dim docRng As Object

    Set appWrd = CreateObject("Word.Application")

3. можно бы ... можно бы ... можно бы сделать что-то подобное:
http://www-01.ibm.com/support/docview.wss?uid=swg21119454

4. или заменить нового каким-то старым Office ... :(  :sceptic:  :)

... не знаю, что вам посоветовать ...
 
ocet p, теперь поиск идет, но вывод результатов какой-то странный - в несколько столбцов - с выводом названий файлов.

Подскажите - как выводить результаты всех файлов - в столбец B7:B14 как я спрашивал в первом сообщении ?
(Указывать названия файлов не нужно - только выписывать текст)
 
например:
:)  
 
ocet p, теперь все работает.
Огромное спасибо.
Страницы: 1
Читают тему (гостей: 1)
Наверх