Highlight key words and paragraphs in all word documents in a set folder

**royUK** · May 17th 2021

I've made some amendments, but a lot of this is guess work.

Code

Sub HighlightWords()
    Dim Word As Range
    Dim WordCollection(2) As String
    Dim Words As Variant
    Dim sFldr As String
    Dim oDoc As Document
    Dim vFile
    
    ' Requires a reference to Microsoft Word xx Object Library
    
    Dim appWd As Word.Application
    Dim wrdDoc As Word.Document
    
'    On Error Resume Next
    Set appWd = GetObject(, "Word.Application")
    On Error GoTo 0
    If appWd Is Nothing Then Set appWd = New Word.Application
    
    appWd.Visible = True
    
    sFldr = "C:\username\My Documents\" '<- change this
    vFile = Dir(sFldr & "*.*")
    'Define list.
    'If you add or delete, change value above in Dim statement.
    WordCollection(0) = "very"
    WordCollection(1) = "just"
    WordCollection(2) = "of course"
    
    Do While vFile <> ""
        Set oDoc = Documents.Open(Filename:=sFldr & vFile)
        'Set highlight color.
    appWd.Options.DefaultHighlightColorIndex = wdYellow
    'Clear existing formatting and settings in Find feature.
    ''/// I don't know where these selections are being made
    appWd.Selection.Find.ClearFormatting
    appWd.Selection.Find.Replacement.ClearFormatting
    'Set highlight to replace setting.
    appWd.Selection.Find.Replacement.Highlight = True
        'Cycle through document and find words in collection.
        'Highlight words when found.
        For Each Word In appWd.ActiveDocument.Words
            For Each Words In WordCollection
                ''///you need some code to select
                With Selection.Find
                    .Text = Words
                    .Replacement.Text = ""
                    .Forward = True
                    .Wrap = wdFindContinue
                    .Format = True
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                Selection.Find.Execute Replace:=wdReplaceAll
            Next
        Next
        oDoc.Close SaveChanges:=False
        vFile = Dir
    Loop
End Sub

Display More

pulsenation · May 17th 2021

Hi Roy,

I'm getting run time error '429': Activex component can't create object, with line 15 of your code highlighted.

I've referenced Microsoft Word 16.0 Object library as requested.

Regards,

Lee

**royUK** · May 17th 2021

Try it without the comma

Code

Set appWd = GetObject("Word.Application")

pulsenation · May 17th 2021

Hi Roy,

Now I get run-time error '-2147221020 (800401e4)': Automation error Invalid Syntax.

The same line as previous is also highlighted.

Regards,

Lee

**royUK** · May 17th 2021

It's the Word VBA, as I said I do not know word VBA. ASs far as I can see that line should be working

pulsenation · May 17th 2021

I made progress, you had a this symbol ( ' ) ('On Error Resume Next) On the previous line.

I have removed the ' and now it runs down to line 41 of the code. For Each Word In appWd.ActiveDocument.Words is now highlighted.

runtime error '13': Type mismatch

Regards,

Lee

pulsenation · May 18th 2021

Hi Roy,

after a few hours of tweaking I have managed to get it to work, please see code below.

However I am getting an intermitent run time error '462': The remote server machine does not exist or is unavailable, Set oDoc = Documents.Open(FileName:=sFldr & vFile) is highlighted on line 32.

This runtime message will pop up but if i stop it and run the macro a second time it will work.

I have a pdf to word macro running straight before it runs this macro. Do you think it might need a delay between macro's in order for it to carry out it's procedure?

I am not sure why it is doing it, any ideas?

Regards,

Lee

Code

Sub Highlight_NRP_Words()
 Application.ScreenUpdating = False
 
 Dim Word As Variant
 Dim WordCollection(2) As String
 Dim Words As Variant
 Dim sFldr As String
 Dim oDoc As Document
 Dim vFile
 
 ' Requires a reference to Microsoft Word xx Object Library
 
 Dim appWd As Word.Application
 Dim wrdDoc As Word.Document
 
 On Error Resume Next
 Set appWd = GetObject("Word.Application")
 On Error GoTo 0
 If appWd Is Nothing Then Set appWd = New Word.Application
 
 appWd.Visible = True
 
 sFldr = "D:\My Documents\VBA\Test folder\" '<- change this
 vFile = Dir(sFldr & "*.*")
 'Define list.
 'If you add or delete, change value above in Dim statement.
 WordCollection(0) = "very"
 WordCollection(1) = "I"
 WordCollection(2) = "error message"
 
 Do While vFile <> ""
 Set oDoc = Documents.Open(FileName:=sFldr & vFile)
 'Set highlight color.
 appWd.Options.DefaultHighlightColorIndex = wdYellow
 'Clear existing formatting and settings in Find feature.
 ''/// I don't know where these selections are being made
 appWd.Selection.Find.ClearFormatting
 appWd.Selection.Find.Replacement.ClearFormatting
 'Set highlight to replace setting.
 appWd.Selection.Find.Replacement.Highlight = True
 'Cycle through document and find words in collection.
 'Highlight words when found.
 For Each Word In appWd.ActiveDocument.Words
 For Each Words In WordCollection
 ''///you need some code to select
 With appWd.Selection.Find
 .Text = Words
 .Replacement.Text = ""
 .Forward = True
 .Wrap = wdFindContinue
 .Format = True
 .MatchCase = False
 .MatchWholeWord = True
 .MatchWildcards = False
 .MatchSoundsLike = False
 .MatchAllWordForms = False
 End With
 appWd.Selection.Find.Execute Replace:=wdReplaceAll
 Next
 Next
 oDoc.Close SaveChanges:=True
 vFile = Dir
 Loop
 Application.ScreenUpdating = True
End Sub

Display More

**royUK** · May 18th 2021

Best thing is to put a short delay to see if it works

pulsenation · May 18th 2021

Morning Roy,

I have got it to work without converting the PDF's to word. MS word opens the PDF in word in the same format, the only problem I have now is I get a save as pop up box asking me which location i would like to save the .doc file to and I have got to press save every time.

If I click cancel on the save as I get Run-time error '4198' Command failed. More than likely because I interupted the loop process.

Below is what is highlighted at the very bottom of the script on the debug.

Is it possible to amend the script to automatically save to the same location it opened the file without the save as box opening up.

I feel that we are so close.

Regards,

Lee

Code

oDoc.Close SaveChanges:=True

**royUK** · May 18th 2021

Attach what you have so far

pulsenation · May 18th 2021

I have on row 61, and it brings up the save as box. I don't wish to be prompted to save as every time it opens a file to highlight, I just want it to save to the location it opened the pdf from.

Regards,

Lee

**royUK** · May 18th 2021

Code

oDoc.Close SaveChanges:=True

That shouldn't open the saveas dialog

pulsenation · May 18th 2021

What's happening is because it's opened the pdf in word, when it has finished it's highlighting action it is trying to then save as a word document.

The save as dialouge box is opening up because it was not originally a word document, if that makes sense.

Regards,

Lee

**royUK** · May 18th 2021

If you want to save to the same path as the workbook, then use ThisWorkBook.Path

pulsenation · May 18th 2021

Apologies Roy,

where and how would I fit that in my script?

Regards,

Lee

**royUK** · May 18th 2021

I'm not sure maybe replace the line with this

Code

oDoc.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & "file name here", _
                      FileFormat:=wdSaveFormat.wdFormatDocument

pulsenation · May 18th 2021

Hi Roy,

getting there. Is it possible to save the file name as the number 1 then increment by one on every save? i.e. 1 2 3 4 5 6 7

The problem with your script is as it loops it can not save the same file name twice.

Regards,

Lee

**royUK** · May 18th 2021

Something like

Code

Dim iX As Integer
''/// within the Loop
iX = iX + 1
oDoc.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & iX, _
 FileFormat:=wdSaveFormat.wdFormatDocument

Or

Code

oDoc.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & Format(Now, "hhmmss"), _
 FileFormat:=wdSaveFormat.wdFormatDocument

pulsenation · May 18th 2021

Hi Roy,

I have used below which seems to of done the trick. It loops through keeping the original PDF file name before saving it as a word document.

I tried your code to increment on 1 but it comes back with an error.

Thanks for all your help.

Regards,

Lee

Code

Documents.Save NoPrompt:=True, _
 OriginalFormat:=wdOriginalDocumentFormat

**royUK** · May 18th 2021

Pleased to help

Highlight key words and paragraphs in all word documents in a set folder

Participate now!

Share

Users Viewing This Thread