VBA Batch Find & Replace for all MSOffice extensions, to replace File Name and Content of the File

[QA_Compliance_Advisor]

while I have read number of threads in varies forums, I am not too sure how to proceed with my issues. My department is going to be asked to replace 1000 + documents in Word, Excel, PowerPoint and Visio 2007 the following;
(1) Old Job Titles with New Job Titles ( 40+ with varies spellings)
(2) replace number of our documents, which
(2a) require to change the title of the file name,
(2b) require to change all document which may refer to that particular file name.

However, also another issue is not all files are in one folder, there is some folders which have subfolder, after subfolder (we control documents and history of each revision, obviously historic documents will not wont to be changed);
(1) I will need to change files within subfolders also.

I do plan to have all the files that need to changed in on location which is separate from any historic files.

the idea I would like is to automate this process with little manual/ human interference as possible.

does anyone have a solution how to do this, either creating a VB application to open and replace the old_text with the new_text and old_doc_number replaced with new_doc_number in a doc and save it with the new_doc_number + doc_title.

[gmaxey]

The forum is full of examples of batch processing files. For the dropdown piece, it would probably be easier to just clear the existing list and fill it with a new list. The following code assumes a content control named "Job Title" and a formfield bookmarked "JobTitle" the contents of each are cleared and filled with a new list.

Just pass your document to process to the macro.

Sub RefillDD(oDoc As Word.Document)
'A basic Word macro coded by Greg Maxey
Dim arrLEs() As String
Dim lngIndex As Long
Dim lngPT As Long
Dim bProt As Boolean
  lngPT = oDoc.ProtectionType
  If lngPT <> wdNoProtection Then
    bProt = True
    oDoc.Unprotect
  End If
  On Error Resume Next
  arrLEs = Split("X,Y,Z", ",")
  With oDoc.SelectContentControlsByTitle("Job Title").Item(1)
    For lngIndex = .DropdownListEntries.Count To 1 Step -1
      .DropdownListEntries(lngIndex).Delete
    Next lngIndex
    For lngIndex = 0 To UBound(arrLEs)
      .DropdownListEntries.Add arrLEs(lngIndex), arrLEs(lngIndex)
    Next lngIndex
  End With
  With oDoc.FormFields("JobTitle")
    .DropDown.ListEntries.Clear
    For lngIndex = 0 To UBound(arrLEs)
      .DropDown.ListEntries.Add arrLEs(lngIndex)
    Next lngIndex
  End With
  If bProt = True Then
    Select Case lngPT
     Case 2
       oDoc.Protect 2, True
     Case Else
       oDoc.Protect lngPT
    End Select
  End If
End Sub

[gmaxey]

This may help: http://gregmaxey.com/word_tip_pages/...der_addin.html

[macropod]

QA_Compliance_Advisor: Please don't post the same question multiple times - once is enough and avoids confusion. I've merged your two threads.

Update: a 3rd thread found and merged ...

[QA_Compliance_Advisor]

@Macropod, thanks - sorry wasn't too sure were to put it.

when doing a find and replace - is there a solution for the following
(1) can I do the same with text in headers & footers replace text?
(2) can I replace pictures/ graphic in a header?

[macropod]

Originally Posted by QA_Compliance_Advisor

when doing a find and replace - is there a solution for the following
(1) can I do the same with text in headers & footers replace text?
(2) can I replace pictures/ graphic in a header?

there are plenty of code samples on this board for doing F/R in headers & footers. See, for example: https://www.msofficeforums.com/word-...html#post63175

As for replacing a picture/graphic, that can't be done with Find/Replace - you'd need to work with the Shapes, ShapeRange or InlineShapes collection. And, if there are multiple pictures/graphics in the range of interest, you have to include the logic for how the one of interest is to be identified.

[QA_Compliance_Advisor]

@ Macropod, thank you for the advice and direction for the headers and footers.

[QA_Compliance_Advisor]

an error is occurring, the Macro will not open and edit the Headers or Footers, but it does the body - could someone review and see if i have the correct code for editing Headers and Footers (in pink)


Private Sub FindAndReplace_docx(oFolder As String)
Application.ScreenUpdating = True
Dim strFolder As String, strFile As String, wdDoc As Document
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean
Dim xlFList As String, xlRList As String, i As Long, Rslt
StrWkBkNm = "\\it17.local\root\UserData\munwil\My Documents\My Documents\Projects\IMS Structure Change\Find and Replace.xlsx"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
Exit Sub
End If
'Get the folder to process
strFolder = oFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)
' Test whether Excel is already running.
On Error Resume Next
bStrt = False ' Flag to record if we start Excel, so we can close it later.
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
Exit Sub
End If
' Record that we've started Excel.
bStrt = True
End If
On Error GoTo 0
'Check if the workbook is open.
bFound = False
With xlApp
'Hide our Excel session
If bStrt = True Then .Visible = False
For Each xlWkBk In .Workbooks
If xlWkBk.FullName = StrWkBkNm Then ' It's open
Set xlWkBk = xlWkBk
bFound = True
Exit For
End If
Next
' If not open by the current user.
If bFound = False Then
' Check if another user has it open.
If IsFileLocked(StrWkBkNm) = True Then
' Report and exit if true
MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use"
If bStrt = True Then .Quit
Exit Sub
End If
' The file is available, so open it.
Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm)
If xlWkBk Is Nothing Then
MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
If bStrt = True Then .Quit
Exit Sub
End If
End If
' Process the workbook.
With xlWkBk.Worksheets(StrWkSht)
' Find the last-used row in column A.
' Add 1 to get the next row for data-entry.
iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
' Output the captured data.
For i = 1 To iDataRow
' Skip over empty fields to preserve the underlying cell contents.
If Trim(.Range("A" & i)) <> vbNullString Then
xlFList = xlFList & "|" & Trim(.Range("A" & i))
xlRList = xlRList & "|" & Trim(.Range("B" & i))
End If
Next
End With
If bFound = False Then xlWkBk.Close False
If bStrt = True Then .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Process each document in the folder
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
'Process each word from the F/R List
For i = 1 To UBound(Split(xlFList, "|"))
With wdDoc.Range
Options.DefaultHighlightColorIndex = wdPink
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = Split(xlFList, "|")(i)
.Replacement.Text = Split(xlRList, "|")(i)
.Execute Replace:=wdReplaceAll
End With
End With
Next
'process Headers with Find and Replace Function
For Each Sctn In wdDoc.Sections
For Each HdFt In Sctn.Headers
With HdFt
If .LinkToPrevious = False Then
'Process the header
With .Range.Find
'Find and Replace parameters for Headers
For i = 1 To UBound(Split(xlFList, "|"))
With wdDoc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = Split(xlFList, "|")(i)
.Replacement.Text = Split(xlRList, "|")(i)
.Execute Replace:=wdReplaceAll
End With
End With
Next
End With
For Each Shp In wdDoc.Shapes
With Shp.TextFrame
If .HasText Then
With .TextRange.Find
'Process each word from the F/R List within Headers which has Shapes
For i = 1 To UBound(Split(xlFList, "|"))
With wdDoc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = Split(xlFList, "|")(i)
.Replacement.Text = Split(xlRList, "|")(i)
.Execute Replace:=wdReplaceAll
End With
End With
Next
End With
End If
End With
Next
End If
End With
Next
Next
'Process Footers with Find and Replace Function
For Each Sctn In wdDoc.Sections
For Each HdFt In Sctn.Headers
With HdFt
If .LinkToPrevious = False Then
With .Range.Find
'Find and Replace parameters for Footers
For i = 1 To UBound(Split(xlFList, "|"))
With wdDoc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = Split(xlFList, "|")(i)
.Replacement.Text = Split(xlRList, "|")(i)
.Execute Replace:=wdReplaceAll
End With
End With
Next
End With
For Each Shp In wdDoc.Shapes
With Shp.TextFrame
If .HasText Then
With .TextRange.Find
'Process each word from the F/R List within Footers which has Shapes
For i = 1 To UBound(Split(xlFList, "|"))
With wdDoc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = Split(xlFList, "|")(i)
.Replacement.Text = Split(xlRList, "|")(i)
.Execute Replace:=wdReplaceAll
End With
End With
Next
End With
End If
End With
Next
End If
End With
Next
Next
'Close the document
wdDoc.Close SaveChanges:=True
'Get the next document
strFile = Dir()
Wend
Application.ScreenUpdating = True
End Sub

[QA_Compliance_Advisor]

Originally Posted by gmaxey

The forum is full of examples of batch processing files. For the dropdown piece, it would probably be easier to just clear the existing list and fill it with a new list. The following code assumes a content control named "Job Title" and a formfield bookmarked "JobTitle" the contents of each are cleared and filled with a new list.

Just pass your document to process to the macro.

Sub RefillDD(oDoc As Word.Document)
...
 End Sub

tried this code however, i am getting a 'runtime error 424' and highlighting
lngPT = oDoc.ProtectionType.

can anyone assist.

[gmaxey]

Code runs without error here so I have no idea why you are getting an error. What is the error description?

[QA_Compliance_Advisor]

Originally Posted by gmaxey

Code runs without error here so I have no idea why you are getting an error. What is the error description?

'runtime error 424'

[QA_Compliance_Advisor]

Guys thanks for the Help the main issue which was to do find and replace has been solved.