Find and Replace character limit issue

kilroy · #1 06-11-2025, 07:14 AM

Hello everyone its been a while since I've been here. Hello Macropod, Greg, Graham. I have the following code that performs a find and replace on multiple documents. The information is collected with a user form and populates cells in the workbook. All text boxes collecting information require inputs well below the character limit of "Replace" in word except for one where it can go above the limit by quite a bit. I've been trying to figure out how to split the information collected but still paste as a long winded paragraph in the processed document that is in the "' Process main document content" section only.

Code:

Sub FindReplaceInWord(ByVal filePath As String)
    Dim wdApp As Object, wdDoc As Object
    Dim criteriaSheet As Worksheet
    Dim replaceText As Variant, replaceValue As Variant
    Dim lastRow As Long, i As Integer
    Dim section As Object, header As Object, footer As Object

    ' Open Word application
    Debug.Print "Opening Word Application..."
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False

    ' Open Word document
    Debug.Print "Opening document: " & filePath
    On Error Resume Next
    Set wdDoc = wdApp.Documents.Open(filePath)
    If wdDoc Is Nothing Then
        Debug.Print "ERROR: Could not open document. Check if file exists."
        wdApp.Quit
        Exit Sub
    End If
    On Error GoTo 0

    ' Reference criteria sheet
    Debug.Print "Loading find-and-replace criteria from worksheet..."
    Set criteriaSheet = ThisWorkbook.Sheets("Table 1")
    lastRow = criteriaSheet.Cells(criteriaSheet.Rows.Count, 1).End(xlUp).Row
    
    ' Read Find & Replace values from column 1 and column 2
    ReDim replaceText(1 To lastRow), replaceValue(1 To lastRow)

    For i = 1 To lastRow
        replaceText(i) = criteriaSheet.Cells(i, 1).Value
        replaceValue(i) = criteriaSheet.Cells(i, 2).Value
    Next i

    ' Process main document content
    Debug.Print "Processing main document content in: " & filePath
    For i = 1 To lastRow
        With wdDoc.Content.Find
            .Text = replaceText(i)
            .Replacement.Text = replaceValue(i)
            .Forward = True
            .Wrap = 1
            .MatchCase = False
            .MatchWholeWord = False
            .Execute Replace:=2
        End With
    Next i

    ' Process headers **without deleting formatting**
    Debug.Print "Processing headers in: " & filePath
    For Each section In wdDoc.Sections
        For Each header In section.Headers
            If header.Exists Then
                Debug.Print "Replacing in Header: " & header.Range.Text
                For i = 1 To lastRow
                    With header.Range.Find
                        .Text = replaceText(i)
                        .Replacement.Text = replaceValue(i)
                        .Forward = True
                        .Wrap = 1
                        .MatchCase = False
                        .MatchWholeWord = False
                        .Execute Replace:=2
                    End With
                Next i
            End If
        Next header
    Next section

    ' Process footers
    Debug.Print "Processing footers in: " & filePath
    For Each section In wdDoc.Sections
        For Each footer In section.Footers
            If footer.Exists Then
                Debug.Print "Replacing in Footer: " & footer.Range.Text
                For i = 1 To lastRow
                    With footer.Range.Find
                        .Text = replaceText(i)
                        .Replacement.Text = replaceValue(i)
                        .Forward = True
                        .Wrap = 1
                        .MatchCase = False
                        .MatchWholeWord = False
                        .Execute Replace:=2
                    End With
                Next i
            End If
        Next footer
    Next section

    Debug.Print "Finished Find & Replace in: " & filePath
    wdDoc.Save
    wdDoc.Close False
    wdApp.Quit
End Sub

Any help is appreciated!

macropod · #2 06-11-2025, 11:08 PM

Try:

Code:

Sub FindReplaceInWord(ByVal filePath As String)
'Add a reference to the Microsoft Forms 2.0 Object Library
Dim wdApp As Object, wdDoc As Object, Sctn As Object, HdFt As Object
Dim criteriaSheet As Worksheet, lastRow As Long, i As Long, StrFnd as String

' Open Word application
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = False

' Open Word document
On Error Resume Next
Set wdDoc = wdApp.Documents.Open(filePath)
If wdDoc Is Nothing Then
  Debug.Print "ERROR: Could not open document. Check if file exists."
  wdApp.Quit: Exit Sub
End If
On Error GoTo 0

'Initialize Microsoft Forms 2.0 Object Library
Dim DataObj As New MSForms.DataObject

' Reference criteria sheet
Set criteriaSheet = ThisWorkbook.Sheets("Table 1")
lastRow = criteriaSheet.Cells(criteriaSheet.Rows.Count, 1).End(xlUp).Row

' Process Document body, then headers & footers in each Section
For i = 1 To lastRow
  DataObj.SetText ActiveSheet.Cells(i, 2).Text: DataObj.PutInClipboard
  StrFnd = criteriaSheet.Cells(i, 1).Value
  With wdDoc.Content.Find
    .Text = StrFnd
    .Replacement.Text = "^c"
    .Forward = True
    .Wrap = 1
    .MatchCase = False
    .MatchWholeWord = False
    .Execute Replace:=2
  End With
  ' Process headers **without deleting formatting**
  For Each Sctn In wdDoc.Sections
    For Each HdFt In Sctn.Headers
      If HdFt.Exists Then
        With HdFt.Range.Find
          .Text = StrFnd
          .Replacement.Text = "^c"
          .Forward = True
          .Wrap = 1
          .MatchCase = False
          .MatchWholeWord = False
          .Execute Replace:=2
        End With
      End If
    Next
    For Each HdFt In Sctn.Footers
      If HdFt.Exists Then
        With HdFt.Range.Find
          .Text = StrFnd
          .Replacement.Text = "^c"
          .Forward = True
          .Wrap = 1
          .MatchCase = False
          .MatchWholeWord = False
          .Execute Replace:=2
        End With
     End If
  Next
Next
wdDoc.Close True: wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set criteriaSheet = Nothing
Debug.Print "Finished Find & Replace in: " & filePath
End Sub

Note that I've eliminated both your array and multiple unnecessary For i = 1 To lastRow loops

kilroy · #3 06-12-2025, 07:31 AM

Thanks Paul!! I bet that's going to cut down the processing time quite a bit as well. I'll test it today and let you know how it goes.

macropod · #4 06-12-2025, 03:20 PM

The following should be more efficient, using the clipboard only when needed:

Code:

Sub FindReplaceInWord(ByVal filePath As String)
'Add a reference to the Microsoft Forms 2.0 Object Library
Dim wdApp As Object, wdDoc As Object, Sctn As Object, HdFt As Object
Dim WkSht As Worksheet, r As Long, StrFnd As String, StrRep As String

' Open Word application
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = False

' Open Word document
On Error Resume Next
Set wdDoc = wdApp.Documents.Open(filePath)
If wdDoc Is Nothing Then
  Debug.Print "ERROR: Could not open document. Check if file exists."
  wdApp.Quit: Exit Sub
End If
On Error GoTo 0

'Initialize Microsoft Forms 2.0 Object Library
Dim DataObj As New MSForms.DataObject

' Reference criteria sheet
Set WkSht = ThisWorkbook.Sheets("Table 1")

' Process Document body, then headers & footers in each Section
For r = 1 To WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
  StrFnd = WkSht.Cells(r, 1).Value: StrRep = WkSht.Cells(r, 2).Value
  If Len(StrRep) > 255 Then DataObj.SetText StrRep: DataObj.PutInClipboard: StrRep = "^c"
  With wdDoc.Content.Find
    .Text = StrFnd
    .Replacement.Text = StrRep
    .Forward = True
    .Wrap = 1
    .MatchCase = False
    .MatchWholeWord = False
    .Execute Replace:=2
  End With
  ' Process headers **without deleting formatting**
  For Each Sctn In wdDoc.Sections
    For Each HdFt In Sctn.Headers
      If HdFt.Exists Then HdFt.Range.Find.Execute Replace:=2
    Next
    For Each HdFt In Sctn.Footers
      If HdFt.Exists Then HdFt.Range.Find.Execute Replace:=2
    Next
  Next
Next
wdDoc.Close True: wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Debug.Print "Finished Find & Replace in: " & filePath
End Sub

kilroy · #5 06-16-2025, 05:47 AM

Thanks Paul that's working pretty good except that it's only using the first character entered into each text box.

macropod · #6 06-16-2025, 03:38 PM

Text box? What is in the cells concerned on those occasions? And what does StrRep return?

You might try:

Code:

StrFnd = WkSht.Cells(r, 1).Text: StrRep = WkSht.Cells(r, 2).Text

instead.

kilroy · #7 Yesterday, 03:33 AM

Paul I found an issue with the saved templates late last night. It wasn't an issue with the code. I will be testing this morning.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Identifying Concentric Square Loops Special Character for Find & Replace	BrianS4	Word	5	07-08-2024 08:59 PM
Find/Replace of funny character	WJSwanepoel	Word	2	06-03-2020 01:58 AM
Find & replace a character in a particuler position	klllmmm	Excel	1	07-27-2016 11:27 PM
Character Limit	Mulith	Mail Merge	2	11-03-2014 03:20 AM
Wildcard Find/Replace deletes extra character	Cosmo	Word	1	06-20-2014 08:49 AM