Multiple replace does not work with 2013

fprm67 · #1 04-06-2014, 02:48 PM

I used attached vba for multiple Find and Replace, but unfortunately this does not work with Word 2013.
This is the link of the vba: http://gregmaxey.com/word_tip_pages/...d_replace.html

I also tried the codes that you reported (https://www.msofficeforums.com/word-...html#post34254) but does not work with Word 2013. Could you please help with the correction of attached vba or your vba code so that it is compatible with Word 2013?

Thank you and kind regards,
Far

macropod · #2 04-06-2014, 03:00 PM

There is nothing about the code in either link you posted that is incompatible with Word 2013 - both work just fine with it.

fprm67 · #3 04-06-2014, 03:11 PM

thank you very much.
I think I have configured it properly. When I run the macro, for a moment the excel file appears and then closes and then I asked the folder. I choose the folder, after a while I see that the files are up to date because the date and time is changed but when I check the word files I find no words changed! Perhaps there is some problem with the language or utf-8? The language of the word file is Persian.

Thanks again
Far

Quote:

Originally Posted by macropod

There is nothing about either the code in the link you posted or the code you quoted that is incompatible with Word 2013 - both work just fine with it. If there is a problem, it's with your implementation.

macropod · #4 04-06-2014, 04:36 PM

I believe the issues you are having with my macro are that the Excel data are stored for the Find/Replace as ASCII characters, but Persian requires the use of non-ASCII Unicode characters. You may get better results with:

Code:

Sub BulkFindReplace()
Application.ScreenUpdating = True
Dim strFolder As String, strFile As String, wdDoc As Document
Dim StrWkBkNm As String, StrWkSht As String
Dim xlApp As Object, xlWkBk As Object, xlWkSht As Object
Dim bStrt As Boolean, bFound As Boolean, lRow As Long, i As Long
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\Workbook Name.xls"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
'Get the folder to process
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", 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
  Set xlWkSht = xlWkBk.Worksheets(StrWkSht)
  lRow = xlWkSht.UsedRange.Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
End With
'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 lRow
    With wdDoc.Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWholeWord = True
        .MatchCase = True
        .Wrap = wdFindStop
        .Text = Trim(xlWkSht.Range("A" & i).Value)
        .Replacement.Text = Trim(xlWkSht.Range("B" & i).Value)
        .Execute Replace:=wdReplaceAll
      End With
    End With
  Next
  'Close the document
  wdDoc.Close SaveChanges:=True
  'Get the next document
  strFile = Dir()
Wend
If bFound = False Then xlWkBk.Close False
If bStrt = True Then xlApp.Quit
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 
Function IsFileLocked(strFileName As String) As Boolean
  On Error Resume Next
  Open strFileName For Binary Access Read Write Lock Read Write As #1
  Close #1
  IsFileLocked = Err.Number
  Err.Clear
End Function

I don't know what the issues might be with the utility in the link.

fprm67 · #5 04-07-2014, 12:31 AM

Ok. Now I tried again and it worked, but it works partially. Attached sending the cases that do not work. When at the beginning or at the end there is "No-width optional break" and does not work with numbers.

macropod · #6 04-07-2014, 01:15 AM

At least some of the issues you're having, especially with numbers, are because the code uses ".MatchWholeWord = True". Without this, there would be a significant risk that some of your other Find/Replace expressions would be updating parts of words. That may also explain why it doesn't work with "No-width optional break" text. I don't understand why you'd bother with rows 5-11, since the Find & Replace text is the same for each of them. For the remainder, you might use a separate worksheet and run a separate Find/Replace without the ".MatchWholeWord = True".

fprm67 · #7 04-07-2014, 01:48 AM

Thank you Paul.
Ok. The items within the lines 5 and 11 are not the same. Line 5 is to remove the white space at the end of a paragraph, and line 11 is to remove the white space between the opening parenthesis and the blank space before the closing parenthesis.

Another question: I often have to do Find & Replace only within the file that is opend, I would like to know how I could modify the code without saving the file and then go on to do Find & Replace?

Thanks

macropod · #8 04-07-2014, 05:14 PM

Try replacing the previous code with the following, which should suffice for doing bulk replacements or just the active document, plus the data on both worksheets:

Code:

Option Explicit
Dim strFolder As String, strFile As String, wdDoc As Document, i As Long
Dim xlApp As Object, xlWkBk As Object, bStrt As Boolean, bFound As Boolean
Dim xlFList1, xlRList1, xlFList2, xlRList2, lRow As Long, StrWkBkNm As String
Const StrWkSht1 As String = "Sheet1": Const StrWkSht2 As String = "Sheet2"
 
Sub ActiveDocFindReplace()
Application.ScreenUpdating = False
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\BulkFindReplace.xls"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
'Get the Find/Replace Data
Call GetData
'Process the document
Call UpdateDoc(ActiveDocument)
Application.ScreenUpdating = True
End Sub
 
Sub MultiDocFindReplace()
Application.ScreenUpdating = False
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\BulkFindReplace.xls"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
'Get the folder to process
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
'Get the Find/Replace Data
Call GetData
'Process each document in the folder
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  Call UpdateDoc(wdDoc)
  'Close & save the document
  wdDoc.Close SaveChanges:=True
  'Get the next document
  strFile = Dir()
Wend
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 
Function IsFileLocked(strFileName As String) As Boolean
  On Error Resume Next
  Open strFileName For Binary Access Read Write Lock Read Write As #1
  Close #1
  IsFileLocked = Err.Number
  Err.Clear
End Function
 
Private Sub GetData()
' 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
  'Initialize the F/R Lists
  xlFList1 = "": xlRList1 = "": xlFList2 = "": xlRList2 = ""
  ' Process the workbook.
  With xlWkBk.Worksheets(StrWkSht1).UsedRange
    ' Find the last-used row.
    lRow = .Rows.Count
    ' Output the captured data.
    For i = 1 To lRow
      ' Skip over empty fields to preserve the underlying cell contents.
      If Trim(.Range("A" & i)) <> vbNullString Then
        xlFList1 = xlFList1 & "|" & Trim(.Range("A" & i))
        xlRList1 = xlRList1 & "|" & Trim(.Range("B" & i))
      End If
    Next
  End With
  With xlWkBk.Worksheets(StrWkSht2).UsedRange
    ' Find the last-used row.
    lRow = .Rows.Count
    ' Output the captured data.
    For i = 1 To lRow
      ' Skip over empty fields to preserve the underlying cell contents.
      If Trim(.Range("A" & i)) <> vbNullString Then
        xlFList2 = xlFList2 & "|" & .Range("A" & i)
        xlRList2 = xlRList2 & "|" & .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
End Sub
 
Sub UpdateDoc(wdDoc As Document)
With wdDoc.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .MatchWholeWord = True
  .MatchCase = True
  .Wrap = wdFindContinue
  'Process each word from the 1st F/R List
  For i = 1 To UBound(Split(xlFList1, "|"))
    .Text = Split(xlFList1, "|")(i)
    .Replacement.Text = Split(xlRList1, "|")(i)
    .Execute Replace:=wdReplaceAll
  Next
  .MatchWholeWord = False
  .MatchCase = False
  'Process each word from the 2nd F/R List
  For i = 1 To UBound(Split(xlFList2, "|"))
    .Text = Split(xlFList2, "|")(i)
    .Replacement.Text = Split(xlRList2, "|")(i)
    .Execute Replace:=wdReplaceAll
  Next
  'Process digits
  For i = 0 To 9
    .Text = Chr(48 + i)
    .Replacement.Text = ChrW(1776 + i)
    .Execute Replace:=wdReplaceAll
  Next
End With
End Sub

Note: With the above code, you don't need to have the numbers in the workbook - there is a separate loop in the code for handling them automatically.

There are now just two subs that you run, either (a) ActiveDocFindReplace; or (b) MultiDocFindReplace.

fprm67 · #9 04-07-2014, 11:39 PM

Thank you Paul.
It works magnificently.

Thanks

fprm67 · #10 04-15-2014, 08:58 AM

Hello Paul,
I have some problems with this code:
1 - it is possible that the language in the code is configured to arbic language? Because I do not change the letter K. In Arabic is ك but in Persian is ک and the code does not replace it.
2 - The code is very heavy and it takes a long time to process the file.

I would also like to know how I can modify the code to be able to do Find & Replace in the html files?

Thank you very much

macropod · #11 04-15-2014, 02:12 PM

Hi Far,

1. I am not aware of anything to do with the use of Arabic or Persian that would affect the macro. In any event, when I run the macro with the workbook you supplied, ك is replaced by ک.

2. If you have many terms and a large document, processing may seem slow, but there is nothing that can be done to make the code run faster, except for getting a faster computer. The code is already about as efficient as it is possible to make it.

3. Except for the file extension, the code should not need any modification to work with html files. If you want to be able to process files that don't have a .doc, .docx or .docm extension, change '.doc' in 'strFile = Dir(strFolder & "\*.doc", vbNormal)' to match whatever file type you want to process. For example, 'strFile = Dir(strFolder & "\*.html", vbNormal)'.

fprm67 · #12 04-15-2014, 03:14 PM

Thank you very much.
yes, you're right. The code also works with K. I made a mistake with a setting of the file.
Cheers

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Replace text in multiple documents?	Roscoe	Word VBA	7	07-31-2017 04:02 PM
Find and replace No longer work	TJH	Word	3	03-25-2014 11:33 PM
Synchronising Outlook 2013 on multiple PCs	paddit	Outlook	1	11-06-2013 02:39 PM
WORD 2013 - Multiple Reviewers: they are all me.	dalyght	Word	8	05-29-2013 12:19 PM
Highlight and then replace multiple words	redhin	Word VBA	5	03-05-2013 05:42 AM