How could I make my code to work with a FOLDER instead of a single doc file?

[makiwara]

The code is working now, but it takes too much time to use it (Part1).

- What it does: there are words in column "A" in Excel and I search for them in a docx file --> if found, I return to the excel file and mark them in column "B".

- However it only works with a single file and not a folder. I have found a solution (Part 2) but I just can't make them work together.

I have tried so hard, but seems I can't do it. Do you have an idea for the loop part? (I think I can solve every other small modification, I am just stucked with the loop thing)

Thank you very much, have a nice day

Part 1, my working code

Option Explicit

Public Sub WordFindAndReplace()
    Dim ws As Worksheet, msWord As Object, itm As Range

    Set ws = ActiveSheet
    Set msWord = CreateObject("Word.Application")


    With msWord
        .Visible = True
        .Documents.Open "C:\Users\teszt1.docx"
        .Activate

      With .ActiveDocument.Content.Find
              .ClearFormatting
              .Replacement.ClearFormatting
                                
                           Dim count As Integer
                           Dim i As Integer
                      
                           count = 1
  
              For i = 2 To 56
                                
                                           count = count + 1
                                        
                                            With msWord.Selection.Find
                                      
                                            .Text = Columns("A").Cells(i, 1).Value2
                                            .Forward = True
                                            .Wrap = wdFindContinue
                                            .Format = False
                                            .MatchCase = False
                                            .MatchWholeWord = True
                                            .MatchWildcards = False
                                            .MatchSoundsLike = False
                                            .MatchAllWordForms = False
                                        
                                            If .Execute Then
                                                Munka1.Range("B" & i).Value = Munka1.Range("B" & i).Value + 1
                                            Else
                                                Munka1.Range("B" & i).Value = "0"
                                            End If
                                          
                                        End With
            Next
        End With
        msWord.Quit SaveChanges:=0 ' wdDoNotSaveChanges (Word constant not defined in Excel)
    End With
End Sub

Part 2: i want to use this method to loop through a whole folder
source of this part: 2 Quick Ways to Batch Print Multiple Word Documents - Data Recovery Blog

Sub BatchPrintWordDocuments()
  Dim objWordApplication As New Word.Application
  Dim strFile As String
  Dim strFolder As String

  strFolder = InputBox("Enter the folder address", "Folder Address", "For example:E:\test word\test\")
  strFile = Dir(strFolder & "*.doc*", vbNormal)

  While strFile <> ""
    With objWordApplication
      .Documents.Open (strFolder & strFile)
      .ActiveDocument.PrintOut
      .ActiveDocument.Close
    End With
    strFile = Dir()
  Wend

  Set objWordApplication = Nothing

End Sub

 

[GWteB]

This might work for you:

Public Sub WordFindAndReplace()
    
    Dim ws As Worksheet, msWord As Object, itm As Range
    Dim count   As Integer
    Dim i       As Integer
    Dim oFP     As FileDialog
    Dim sFile   As String
    Dim sFolder As String

    Set oFP = Application.FileDialog(msoFileDialogFolderPicker)
    With oFP
        .Title = "Choose folder"
        .InitialFileName = Environ("userprofile") & "\documents\"
        If .Show = -1 Then
            sFolder = .SelectedItems(1)
        Else
            MsgBox "Canceled"
        End If
    End With
    Set oFP = Nothing
    
    If Len(sFolder) > 0 Then
        Set ws = ActiveSheet
        Set msWord = CreateObject("Word.Application")
        msWord.Visible = True
        
        sFile = Dir(sFolder & "\*.doc*", vbNormal)
        With msWord
            While Len(sFile) > 0
                .Documents.Open sFolder & "\" & sFile
                .Activate
                With .ActiveDocument.Content.Find
                    .ClearFormatting
                    .Replacement.ClearFormatting
                End With
                count = 1
                For i = 2 To 56
                    count = count + 1
                    With .Selection.Find
                        .Text = ws.Columns("A").Cells(i, 1).Value2
                        .Forward = True
                        .Wrap = 1  'wdFindContinue
                        .Format = False
                        .MatchCase = False
                        .MatchWholeWord = True
                        .MatchWildcards = False
                        .MatchSoundsLike = False
                        .MatchAllWordForms = False
                        If .Execute Then
                            Munka1.Range("B" & i).Value = Munka1.Range("B" & i).Value + 1
                        Else
                            Munka1.Range("B" & i).Value = "0"
                        End If
                    End With
                Next
                .ActiveDocument.Close SaveChanges:=0
                sFile = Dir()
            Wend
            .Quit SaveChanges:=0 ' wdDoNotSaveChanges (Word constant not defined in Excel)
        End With
    End If
End Sub

 

[makiwara]

Working like a charm! GwteB, thank you very much for your help, you are a genius! You saved me, I wish you the best! Have a nice day )))

 

[GWteB]

Glad to help and thanks for letting me know.