Use excel macro to find text in .docx file

[Slade2000]

Hi

I am looking for a macro that will take the value of a cell "A1" and search for it in a .docx file and then just add the word "Yes" into cell "B1"

This code is what i have and it opens the word doc but then i need to perform the find.

Thank you

Sub FindName()
     
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("C:\Test\ACBS.docx")
Dim FindWord As String
FindWord = Sheet1.Range("A1").Value
MsgBox FindWord
************
Search the word and set "B1" to "Yes"

************
End Sub

 

[Ralajer]

Give this a try. I was able to get the desired results in all my test.

Sub FindName()     
    Dim wrdApp As Object
    Dim wrdDoc As Object
    Set wrdApp = CreateObject("Word.Application")
        wrdApp.Visible = True
    Set wrdDoc = wrdApp.Documents.Open("C:\Test\ACBS.docx")
    Dim FindWord As String
    Dim result As String
    FindWord = Sheet1.Range("A1").Value
   ' MsgBox FindWord
    
    '// Defines selection for Word's find function
    wrdDoc.SelectAllEditableRanges
    
    '// Word Find Method Setup Block
    With wrdDoc.ActiveWindow.Selection.Find
        .Text = FindWord
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1 ' wdFindContinue (Word constant not defined in Excel)
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    
    '// Execute find method selects the found text if found
    wrdDoc.ActiveWindow.Selection.Find.Execute
    
    '// Store Selected text
    result = wrdDoc.ActiveWindow.Selection.Text
    
    '// Test if the selection string found match value required converted case for comparison
    If UCase(result) = UCase(FindWord) Then
        Sheet1.Range("B1").Value = "YES"
    Else
        Sheet1.Range("B1").Value = "NO"
    End If
    '// Close and don't save application
    wrdApp.Quit SaveChanges:=0 ' wdDoNotSaveChanges (Word constant not defined in Excel)
    
End Sub

 

[AlphaFrog]

Another method...

    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Set wrdApp = CreateObject("Word.Application")
    wrdApp.Visible = True
    Set wrdDoc = wrdApp.Documents.Open("C:\Test\ACBS.docx")
    Dim FindWord As String
    FindWord = Sheet1.Range("A1").Value
    MsgBox FindWord
    
    wrdApp.Selection.WholeStory
    wrdApp.Selection.Find.ClearFormatting
    With wrdApp.Selection.Find
        
        .Text = FindWord
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        
        If .Execute Then
            Sheet1.Range("B1").Value = "Yes"
        Else
            Sheet1.Range("B1").Value = "No"
        End If
        
    End With

 

[Slade2000]

Ralajer yours work perfectly. The only problem i have now is that some have suffices and starts with the same and although the text does not exist in the document it tell exel that it does. For instance

ACBS_EOD - This one does not exist
ACBS_EOD_SA - This one does exist

And still it will return that both do exist. Is there a way to find exact text?

 

[Ralajer]

That will be an easy fix change the MatchWholeWord = False to = True. AlphaFrog included that in his code which is probably a little better than mine because I bet that AlphaFrog knows Word Object Library a little/a lot better than me.
​

 

[Slade2000]

I have used both pieces of code and changed the WholeWord to true but still get the same result.

Sub FindText2()

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("C:\Test\ACBS.docx")
Dim FindWord As String
For i = 2 To 27
FindWord = Sheet1.Range("A" & i).Value
'MsgBox FindWord

wrdApp.Selection.WholeStory
wrdApp.Selection.Find.ClearFormatting
With wrdApp.Selection.Find

.Text = FindWord
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

If .Execute Then
Sheet1.Range("B" & i).Value = "Yes"
Else
Sheet1.Range("B" & i).Value = "No"
End If

End With
Next
End Sub

 

[Ralajer]

I tried the code that you submitted and I am not having the partial word match problem that you seem to be experiencing. I not sure why you are you are having that issue it might have something to do with the docx that is being searched.

 

[Slade2000]

I have created a plan .dox file now with the same and got the same results. The red is what i have problems with.

This is the excel entries

ACBS_DCI_Archive	No
ACBS_Run_Backup	No
LDN_ACBS_BIM_Alert	No
ACBS_EOD_Dummy	No
ACBS_EOD	Yes
ACBS_Datamart	Yes
Sbyn_ACBSTransferDoneDat	No
Sbyn_ACBSTransferOthers	No
ACBS_Interface_Extracts	No
ACBS_EOD_SA_Dummy	No
ACBS_EOD_SA	Yes
Sbyn_ACBSSATransferDoneDat	No
ACBS_SA_Datamart	No
ACBS_SA_Interface_Extracts	No
Funding_Recon_SA	No
F_RECON_TRANSFER	No
ACBS_SA_STATEMENTS_XML	No
ADS_HOLIDAY_FILE	No
ACBS_SA_STATEMENTS_BATCH	Yes
ACBS_EOD_SF_Dummy	No
Sbyn_ACBSSFLTransferDoneDat	No
Sbyn_ACBSSFLTransferOthers	No
ACBS_SF_Datamart	No
ACBS_SF_Interfaces_Extracts	No
ACBS_EOD_SF	No
ACBS_Intraday This is my .doc entries ACBS_EOD_SA ACBS_SA_STATEMENTS_BATCH ACBS_Datamart	No

<colgroup><col><col></colgroup><tbody>
</tbody>

 

[AlphaFrog]

This removes the underscores in the word doc and from the "search-for" term. Then does the search.

    [COLOR=darkblue]Dim[/COLOR] wrdApp [COLOR=darkblue]As[/COLOR] Word.Application
    [COLOR=darkblue]Dim[/COLOR] wrdDoc [COLOR=darkblue]As[/COLOR] Word.Document
    [COLOR=darkblue]Set[/COLOR] wrdApp = CreateObject("Word.Application")
    wrdApp.Visible = [COLOR=darkblue]True[/COLOR]
    [COLOR=darkblue]Set[/COLOR] wrdDoc = wrdApp.Documents.Open("C:\Test\ACBS.doc")
    [COLOR=darkblue]Dim[/COLOR] FindWord [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
    FindWord = Sheet1.Range("A1").Value
    MsgBox FindWord
    
    [COLOR=darkblue]With[/COLOR] wrdDoc.Content.Find
        .ClearFormatting
        .Forward = [COLOR=darkblue]True[/COLOR]
        .Wrap = wdFindContinue
        .Format = [COLOR=darkblue]False[/COLOR]
        .MatchCase = [COLOR=darkblue]False[/COLOR]
        .MatchWholeWord = [COLOR=darkblue]True[/COLOR]
        .MatchWildcards = [COLOR=darkblue]False[/COLOR]
        .MatchSoundsLike = [COLOR=darkblue]False[/COLOR]
        .MatchAllWordForms = [COLOR=darkblue]False[/COLOR]
        
        [COLOR=green]'Remove underscores from word document text[/COLOR]
        .Execute FindText:="_", ReplaceWith:="", Replace:=wdReplaceAll
        
        .Text = Replace(FindWord, "_", "") [COLOR=green]'Remove underscores from "Search-for" text[/COLOR]
        [COLOR=darkblue]If[/COLOR] .Execute [COLOR=darkblue]Then[/COLOR]
            Sheet1.Range("B1").Value = "Yes"
        [COLOR=darkblue]Else[/COLOR]
            Sheet1.Range("B1").Value = "No"
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]

 

[Slade2000]

AplhaDog i tried that but as well did not work so i went this way and now it works fine.

Sub FindText2()

    Cells.Replace What:="_", Replacement:="", LookAt:=xlPart, SearchOrder:= _
    xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Set wrdApp = CreateObject("Word.Application")
    wrdApp.Visible = True
    Set wrdDoc = wrdApp.Documents.Open("C:\Test\ACBS.docx")
    Dim FindWord As String
    'MsgBox FindWord
    
    wrdApp.Selection.WholeStory
    wrdApp.Selection.Find.ClearFormatting
    
    With wrdApp.Selection.Find
        .Execute FindText:="_", ReplaceWith:="", Replace:=wdReplaceAll
        .Text = Replace(FindWord, "_", "")
    End With
    
    For i = 2 To 27
    FindWord = Sheet1.Range("A" & i).Value
    
    With wrdApp.Selection.Find
      
        .Text = FindWord
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        
        If .Execute Then
            Sheet1.Range("B" & i).Value = "Yes"
        Else
            Sheet1.Range("B" & i).Value = "No"
        End If
          
    End With
    Next
    wrdApp.Quit SaveChanges:=0 ' wdDoNotSaveChanges (Word constant not defined in Excel)

End Sub