Open Multiple WORD FILES based on a list, perform tasks , save and close-CodePudding

I'd like to open a bunch of word files, from a list of file names in my excel workbook, activate the opened word files, perform a text replacement, and save the changes. I can't make the liaison between Excel VBA and Word files.

Dim wdApp As Object, wddoc As Object
'Declare a string variable for Word document
Dim strDocName As String


On Error Resume Next

Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
strDocName = xDPathStr \ "FILENAME.docx"  '(xDPathStr is the path I have defined earlier with all the word files)' 

'Open Word File
wdApp.Activate
Set wddoc = wdApp.Documents(strDocName)
If wddoc Is Nothing Then Set wddoc = wdApp.Documents.Open(strDocName)
wddoc.Activate

wrdApp.Visible = True

CodePudding user response：

Modify Word Files From a List in Excel

It is assumed that the file names are in column A. It will open each file and replace all occurrences of one string with another.
The focus here is on how to reference (open) Word, open files, modify them (not so much), close them with saving changes, and finally close Word only if it was initially closed.

Option Explicit

Sub VisitWord()

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Late Binding (not recommended at this stage)
' When you get familiar with how it works, switch to Late Binding:
'    Dim wdApp As Object
'    Dim WordWasClosed As Boolean
'    On Error Resume Next ' see if Word is open
'        Set wdApp = GetObject(, Word.Application) ' attempt to create a reference to it
'    On Error GoTo 0
'    If wdApp Is Nothing Then ' Word is not open
'        WordWasClosed = True
'        Set wdApp = CreateObject("Word.Application") ' open and create a reference to it
'    End If
'    wdApp.Visible = True ' default is false; outcomment when done testing
'    Dim wdDoc As Object
'    ' etc.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Early Binding
' For this to work, in Excel, you need to create a reference to
' Tools > References > Microsoft Word 16.0 Object Library
' Use this to have the Word intellisense work for you.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Const WordFolderPath As String = "C:\Test\"
    Const FINDSTRING As String = "Old String"
    Const REPLACESTRING As String = "New String"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
    Dim rg As Range
    Set rg = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
    
    Dim wdApp As Word.Application
    Dim WordWasClosed As Boolean
    
    On Error Resume Next ' see if Word is open
        Set wdApp = Word.Application ' attempt to create a reference to it
    On Error GoTo 0
    If wdApp Is Nothing Then ' Word is not open
        WordWasClosed = True
        Set wdApp = New Word.Application ' open and create a reference to it
    End If
    wdApp.Visible = True ' default is false; outcomment when done testing
    
    Dim cell As Range
    Dim wdDoc As Word.Document
    Dim WordFileName As String
    Dim WordFilePath As String
    
    For Each cell In rg.Cells
        WordFileName = CStr(cell.Value)
        If Len(WordFileName) > 0 Then
            WordFilePath = WordFolderPath & WordFileName
            If Len(Dir(WordFilePath)) > 0 Then ' file exists
                Set wdDoc = wdApp.Documents.Open(WordFilePath)
                
                ' Here you do the damage...
                wdDoc.Content.Find.Execute _
                    FindText:=FINDSTRING, _
                    ReplaceWith:=REPLACESTRING, _
                    Format:=True, _
                    Replace:=wdReplaceAll
                
                wdDoc.Close SaveChanges:=True
            End If
        End If
    Next cell
    
    If WordWasClosed Then wdApp.Quit
    
End Sub

CodePudding user response：

So this is the code i've come up with so far:

Dim wdApp As Object, wddoc As Object
'Declare a string variable for Word document
Dim strDocName As String


On Error Resume Next

Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
strDocName = xDPathStr \ "FILENAME.docx"  '(xDPathStr is the path I have defined earlier with all the word files)' 

'Open Word File
wdApp.Activate
Set wddoc = wdApp.Documents(strDocName)
If wddoc Is Nothing Then Set wddoc = wdApp.Documents.Open(strDocName)
wddoc.Activate

wrdApp.Visible = True

CodePudding user response：

Here is some sample code that I created recently to loop through cells in Excel, which are paths to Word files. Each Word file is opened, scanned for a table (in Word), and copy/paste to Excel. See if you can start with this. Post back if you have additional questions.

Sub LoopThroughAllWordFiles()

Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim oTbl As Word.Table
Dim strFolder As String, strFile As String
Dim WkSht As Worksheet
Dim cnt As Long
Dim tableCount As Long
Dim lrow As Long
Dim lastrow As Long
Dim file As String
Dim rng As Range, cell As Range
Dim objDoc As Object
Dim objWord As Object


Dim StartTime As Double
Dim SecondsElapsed As Double

StartTime = Timer

Set rng = Worksheets("Files").Range("A1:A200")
Worksheets("Word_Tables").Select

filecounter = 1
cnt = 1


Set objWord = CreateObject("Word.Application")
obj.Word.Visible = False

For Each cell In rng.SpecialCells(xlCellTypeVisible)
MyStr = Right(cell, 5)
   
   If MyStr = ".docx" Then
   
   mylength = Len(cell)
   pos = InStrRev(cell, "\")
   
   strFolder = Left(cell, pos)
   strFile = Right(cell, mylength - pos)
   
      Worksheets("Word_Files").Select
      Set objWord = wdApp.Documents.Open(Filename:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
      Set sht = ThisWorkbook.Worksheets("Word_Files")
      lastrow = Worksheets("Word_Files").UsedRange.Rows.Count   1
      
         totTbl = objDoc.Tables.Count
         Debug.Print totTbl
         
            For Each oTbl In objDoc.Tables
            
               strCellText = oTbl.cell(1, 1).Range.Text
               strCellText = LCase(strCellText)
               Debug.Print strCellText
            
                  If strCellText Like "*data input*" Then
                  
                     Worksheets("Word_Files").Range("A" & lastrow) = strFolder & strFile
                     On Error Resume Next
                     
                        If cnt = 1 Then
                           lastrow = lastrow
                        Else
                           lastrow = ActiveSheet.UsedRange.Rows.Count
                        End If
                        
                           oTbl.Range.Copy
                           Range("B" & lastrow).Select
                           sht.Paste
                        cnt = cnt   1
                        
                  End If
                  
            Next oTbl
   
   End If

filecounter = filecounter   1
Debug.Print filecounter

objWord.Close

Next cell

objDoc.Quit
Set objDoc = Nothing
objWord.Quit
Set objWord = Nothing

SecondsElapsed = Round(Timer - StartTime, 2)
SecondsFinal = SecondsElapsed / 60
MsgBox ("Code ran in " & SecondsFinal & "minutes.")

End Sub