Find and Replace using Excel range

dmarie123 · #1 02-15-2013, 02:35 PM

Hi all,

I've spent the day googling and found a bunch of snippets of code but I don't know exactly how to put it all together or if I'm approaching this correctly. The background is this: I have a word document that comes to me with TONS of changes to be made, mostly glaring grammatical errors. I have a lengthy find and replace sequence, so lengthy that I've exceeded “the rules” and it’s no longer performing all the changes.

I've explored writing an additional macro to call up the others but then I found the code from Mr. Paul Edstein that I’ve pasted below and I’m questioning if I’m going about this entirely wrong. So, currently there are about 75+ find and replace actions that need to occur, my word document needs to be searched for words and phrases and then replaced with other words and phrases. Each instance will not necessarily always appear in the word doc. I do have an excel file w/ a find column and the subsequent replacement text. Regardless of how we proceed the following points are key:

1. The macro needs to run until it reaches the end of the excel list so that I can continue to add to the list.
2. Track changes has to be on[/b] for these changes (which I can't figure out how to do in Paul's code below, ARGH!!)

The following macro does work but the string would be very long and updating the macro across more than one computer would be sort of a pain. (found here originally)

Code:

Sub MultiReplace()
Dim StrOld As String, StrNew As String
Dim RngFind As Range, RngTxt As Range, i As Long
StrOld = "A student 9,A student 8,A student 7"
StrNew = "A Student 9,A Student 8,A Student 7"
Set RngTxt = Selection.Range
For i = 0 To UBound(Split(StrOld, ","))
  Set RngFind = RngTxt.Duplicate
  With RngFind.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = Split(StrOld, ",")(i)
    .Replacement.Text = Split(StrNew, ",")(i)
    .Format = False
    .MatchWholeWord = True
    .MatchCase = True
    .MatchAllWordForms = False
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
  End With
Next
End Sub

Is it better to run it out of Excel like Paul did below?? Your opinions would be hugely appreciated! I'd like to be able to pass this to one of my colleagues who is also stuck in mundane editing hell

Excel code from Paul's original post:

Code:

Sub ReplaceExcelCellValueInMswordFile()
Dim wdApp As Word.Application, wdDoc As Word.Document
Dim dlg As Variant, dataPath As Variant
Dim iCount As Long, r As Long
Dim strSearch, strReplace As String
r = 3
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
  Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Set dlg = Application.FileDialog(msoFileDialogFilePicker)
dlg.Title = "Select your MS word File for replace the word"
dlg.AllowMultiSelect = False
If dlg.Show = -1 Then
  dataPath = dlg.SelectedItems(1)
End If
Set wdDoc = wdApp.Documents.Open(dataPath, AddToRecentFiles:=False)
   wdApp.Visible = True
strSearch = Cells(r, 1).Value
While strSearch <> ""
  strReplace = Cells(r, 2).Value
  iCount = 0
  wdApp.Options.DefaultHighlightColorIndex = wdYellow
  With wdDoc.Content.Find
    .Text = strSearch
    .Replacement.Text = strReplace
    .Replacement.Highlight = True
    .Wrap = wdFindContinue
    .Execute Replace:=wdReplaceAll
  End With
  strSearch = wdDoc.Range.Text
  iCount = (Len(strSearch) - Len(Replace(strSearch, strReplace, ""))) / Len(strReplace)
  If iCount > 1 Then
    wdApp.Options.DefaultHighlightColorIndex = wdRed
     With wdDoc.Content.Find
      .Text = strReplace
      .Replacement.Text = strReplace
      .Replacement.Highlight = True
      .Wrap = wdFindStop
      .Execute Replace:=wdReplaceOne
     End With
  End If
  r = r + 1
  strSearch = Cells(r, 1).Value
Wend
MsgBox "Done"
End Sub

I don’t need the formatting changes but I would add ".MatchCase = True" because some of my changes are simply capitalization.

If I have to choose I think Paul’s code is the best option because I can update a spreadsheet easily. I also like that I get to choose the Word document. However, I don’t know if turning on track changes for the word document is a deal breaker if I’m starting in Excel? As always, any help is appreciated. Also, I get an error about the number of arguments when I run Paul's code on my PC, "450" and MS Word does something where it's opening blank windows that it doesn't allow me to close. Any input is appreciated. Thanks for your time!

Thank you!
Donna

macropod · #2 02-15-2013, 03:22 PM

Hi Donna,

For a bulk Find/Replace that uses an Excel workbook as the data source, see: https://www.msofficeforums.com/word/...html#post34254
For an interactive version, see: https://www.msofficeforums.com/word-...html#post31849
Note that these macros are run from Word, not from Excel, and work on whatever is the active document. As for use with track changes, everything should be fine - AFAIK it's only when you're trying to modify content the way you were in the other thread (https://www.msofficeforums.com/word-...ormatting.html) that you'll run into problems.

dmarie123 · #3 02-15-2013, 03:34 PM

Thank you for the speedy response! I knew someone had to have already asked the question. I'll give it a go. Have a wonderful weekend!!

dmarie123 · #4 03-01-2013, 01:53 PM

Hi,

Question 1: I'm working on combining some of the macros that all of you have provided/helped me with (thank you again Greg and Paul

). I've tried adding code to Sub BulkFindReplace (code posted below) so that it will apply the following formatting to all the word docs (.docx) in the folder:
Align "left"
Arial Font
size 11

I've tried putting the code in multiple places using wdDoc and range. I was able to make it work a couple times but then couldn't replicate it. I don't understand why it would work once and then not again.

I've used the following:

Code:

Selection.WholeStory
Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
Selection.Font.Size = 11
Selection.Font.Name = "Arial"

Question 2: Also, if I do decide to turn track changes on for a folder of .docx folders (MS Word 2007) how would I do that? Again, I was able to make it work a few times, I'm assuming the "activeDocument" part is what prevents it from applying track changes to all the documents. The code I wrote either didn't work again or didn't work on all of them.

Question 3:

Code:

'Add to Student ID
    .Text = "SID[:][ ][ ]{1,2}[0-9]{10}"
    .Replacement.Text = "^& (Approved: / / )"
    .Execute Replace:=wdReplaceAll

When I run the above section in the other macro it works great but when I add it to Sub BulkFindReplace below it goes crazy. By crazy I mean it adds the "(Approved: / / )" part about twenty times. In keeping with my theme thus far, I can make it work "crazy" or not at all????

Please help, I'm thoroughly and completely confused.

Code:

Sub BulkFindReplace()
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 = "C:\Documents" & "\MACRO.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
  ' 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 doc from the F/R List
  For i = 1 To UBound(Split(xlFList, "|"))
    With wdDoc.Range
        With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWholeWord = True
        .MatchCase = True
        .Wrap = wdFindStop
        .Text = Split(xlFList, "|")(i)
        .Replacement.Text = Split(xlRList, "|")(i)
        .Execute Replace:=wdReplaceAll
        End With
      End With
         
' Add "-" to IDs, Add “(Approved: / / )”, Change Dates to Long Format

With wdDoc.Range
   With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True

     'Add to SID
    .Text = "SID[:][ ][ ]{1,2}[0-9]{10}"
    .Replacement.Text = "^& (Approved: / / )"
    .Execute Replace:=wdReplaceAll
    
    'Fix IDs Part 1
    .Text = "(ID[:][ ][ ]{1,2}[0-9]{2})([0-9]{7})"
    .Replacement.Text = "\1-\2"
    .Execute Replace:=wdReplaceAll
       
    'Fix IDs Part 2
    .Text = "(ID[ ]{1,2}[0-9]{2})([0-9]{7})"
    .Replacement.Text = "\1-\2"
    .Execute Replace:=wdReplaceAll
    
    'Fix Date ranges
    .Text = "[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}-[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}"
    .Replacement.Text = ""
    .Execute
    
  End With
  Do While .Find.Found
    StrTxt = Format(Trim(Split(.Text, "-")(0)), "MMMM D, YYYY")
    Select Case Trim(LCase(.Words.First.Previous.Previous.Words.First))
      Case "between": StrTxt = StrTxt & " and "
      Case "from": StrTxt = StrTxt & " to "
      Case "of": StrTxt = StrTxt & " through "
    End Select
    StrTxt = StrTxt & Format(Trim(Split(.Text, "-")(1)), "MMMM D, YYYY")
    .Text = StrTxt
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
  End With
  Next
  'Close 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

Thank you (again) for your time.
-Donna

macropod · #5 03-01-2013, 04:51 PM

Hi Donna,

The fundamental problem with that you have all the Find/Replace code for the dates and SSIDs inside the same loop that's processing the Excel data. So, every time a Find/Replace for the Excel data are done, so too is a set for the SSIDs and dates.

I also noticed some 'issues' with other aspects of your code. In the code I originally posted, the Find expression for the SSIDs was:
.Text = "SSID[: ]{1,2}[0-9]{10}"
but you're using:
.Text = "SID[:][ ][ ]{1,2}[0-9]{10}"
The essential difference here is that my code will find SSID followed by either a colon or a space or both, whereas your finds SID followed by a colon, a space then one or two spaces. In your code, neither the colon nor the first two spaces after it are optional, so 'SID 1234567890', for example, would not be found.

Try the following. It incorporates the more recent enhancements I made to the code in your other thread (https://www.msofficeforums.com/word-...html#post45544), plus some additional tweaks.

Code:

Sub BulkFindReplace()
Application.ScreenUpdating = True
Dim strFolder As String, strFile As String, wdDoc As Document
Dim TrkStatus As Boolean, StrTxt As String, Rng As Range, RngTmp As Range
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 = "C:\Users\Macropod\Documents\Attachments\Temp\FindWords.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
 
  ' 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)
  With wdDoc
 
    'Store the current change-tracking status
    TrkStatus = .TrackRevisions
    'Ensure change-tracking is on
    .TrackRevisions = True
 
    Set Rng = .Range(0, 0)
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .Wrap = wdFindContinue
 
        ' Process each word doc from the F/R List
        For i = 1 To UBound(Split(xlFList, "|"))
          .Text = Split(xlFList, "|")(i)
          .Replacement.Text = Split(xlRList, "|")(i)
          .Execute Replace:=wdReplaceAll
        Next
 
        'Update SSN, SSID & Date range formatting
        .Wrap = wdFindStop
        .MatchWildcards = True
        .Replacement.Text = ""
 
        'Fix SSNs
        'Ensure SSNs are correctly formatted with 'SSN' folowed by a colon, then a
        'single non-breaking space, followed by the number in the ##-####-### format
      End With
        .Start = Rng.Start
        .Collapse wdCollapseStart
        'First, work on unformatted SSNs
      With .Find
        .Text = "SSN[: ^0160]{1,}[0-9]{9}>"
        .Execute
      End With
      Do While .Find.Found
        'Ensure SSN is folowed by a colon, then a single non-breaking space
        .MoveStart wdCharacter, 3
        If Left(.Text, 1) <> ":" Then .InsertBefore ":"
        .MoveStart wdCharacter, 1
        Set RngTmp = .Characters.First
        With RngTmp
          If .Characters.First.Next Like "[ " & Chr(160) & "]" Then
            .MoveEndWhile " ", wdForward
            .MoveEndWhile Chr(160), wdForward
            .Text = Chr(160)
          ElseIf .Characters.First = " " Then
            .Text = Chr(160)
          End If
        End With
        'Hypenate the number with non-breaking hyphens
        .Start = .End - 7
        .End = .End - 3
        .InsertAfter Chr(30)
        .InsertBefore Chr(30)
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
      'Check that other SSNs that were correctly formatted as to the number
      'are also folowed by a colon, then a single non-breaking space
      .Start = Rng.Start
      .Collapse wdCollapseStart
      With .Find
        .Text = "SSN[: ]{1,}[0-9]{2}"
        .Execute
      End With
      Do While .Find.Found
        .MoveStart wdCharacter, 3
        If Left(.Text, 1) <> ":" Then .InsertBefore ":"
        .MoveStart wdCharacter, 1
        Set RngTmp = .Characters.First
        With RngTmp
          If .Characters.First.Next Like "[ " & Chr(160) & "]" Then
            .MoveEndWhile " ", wdForward
            .MoveEndWhile Chr(160), wdForward
            .Text = Chr(160)
          ElseIf .Characters.First = " " Then
            .Text = Chr(160)
          End If
        End With
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
 
      'Fix SSIDs
      'Ensure SSIDs are correctly formatted with 'SSN' folowed by a colon, then a
      'single non-breaking space, followed by the number in the ##-######## format
      .Start = Rng.Start
      .Collapse wdCollapseStart
      With .Find
        .Text = "SSID[: ^0160]{1,}[0-9]{10}>"
        .Execute
      End With
      Do While .Find.Found
        'Ensure SSID is folowed by a colon, then a single non-breaking space
        .MoveStart wdCharacter, 4
        If Left(.Text, 1) <> ":" Then .InsertBefore ":"
        .MoveStart wdCharacter, 1
        Set RngTmp = .Characters.First
        With RngTmp
          If .Characters.First.Next Like "[ " & Chr(160) & "]" Then
            .MoveEndWhile " ", wdForward
            .MoveEndWhile Chr(160), wdForward
            .Text = Chr(160)
          ElseIf .Characters.First = " " Then
            .Text = Chr(160)
          End If
        End With
        'Hypenate the number with a non-breaking hyphen
        .Start = .End - 8
        .InsertBefore Chr(30)
        'Ensure there is provision for the approval date:
        Set RngTmp = .Characters.Last
        RngTmp.MoveEnd wdCharacter, 30
        If InStr(RngTmp, "Approved") = 0 Then
          .Collapse wdCollapseEnd
          .Text = " (Approved:   /   /   )"
        End If
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
      'Check that other SSIDs that were correctly formatted as to the number
      'are also folowed by a colon, then a single non-breaking space
      .Start = Rng.Start
      .Collapse wdCollapseStart
      With .Find
        .Text = "SSID[: ]{1,}[0-9]{2}"
        .Execute
      End With
      Do While .Find.Found
        .MoveStart wdCharacter, 4
        If Left(.Text, 1) <> ":" Then .InsertBefore ":"
        .MoveStart wdCharacter, 1
        Set RngTmp = .Characters.First
        With RngTmp
          If .Characters.First.Next Like "[ " & Chr(160) & "]" Then
            .MoveEndWhile " ", wdForward
            .MoveEndWhile Chr(160), wdForward
            .Text = Chr(160)
          ElseIf .Characters.First = " " Then
            .Text = Chr(160)
          End If
        End With
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
 
      'Fix Date Ranges
      .Start = Rng.Start
      .Collapse wdCollapseStart
      With .Find
        .Text = "[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}-[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}"
        .Execute
      End With
      Do While .Find.Found
        Select Case Trim(LCase(.Words.First.Previous.Previous.Words.First))
          Case "between": StrTxt = " and "
          Case "from": StrTxt = " to "
          Case "of": StrTxt = " through "
        End Select
        .Start = .Start + InStr(.Text, "-") - 1
        .End = .Start + 1
        .Duplicate.Text = StrTxt
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
 
      'Check that all other inter-numeral hyphens are non-breaking
      .Start = Rng.Start
      .Collapse wdCollapseStart
      With .Find
        .Text = "[0-9][^45^0150^0151][0-9]"
        .Execute
      End With
      Do While .Find.Found
        .MoveStart wdCharacter, 1
        .MoveEnd wdCharacter, -1
        If .Text <> Chr(30) Then .Text = Chr(30)
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
 
    'Restore the original change tracking status
    .TrackRevisions = TrkStatus
    'Close & save the document
    .Close SaveChanges:=True
  End With
 
  'Get the next document
  strFile = Dir()
Wend
Set Rng = Nothing: Set RngTmp = 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

dmarie123 · #6 03-06-2013, 02:34 PM

Hi Paul,

I apologize for not responding sooner. I was snowed in with the rest of the Midwest.

As far as the numbers, I want to match the format of the text that is found so if it
finds a prefix with a colon then the found text and colon should stay as is. If it only finds the text then it should also stay as is. I don't want to add a colon.
From: To:
SSID: 123456789 >>> SSID: 12-3456789
The above will either have two spaces after the colon or it will appear w/in text:
SSID 123456789 >>> SSID 12-3456789

The other number will also appear after the text, a colon, and two spaces:
SID2: 1234567891 >>> SID2: 1234567891 (Approved: )

That's why I did the numbers that way. I wasn't aware yours caught both. If I add an extra space inside the brackets will it do both a colon and two spaces?? That would be cleaner code-wise.

Also, where do I put the code to format the text to Arial, size 11, left-justified?

Thank you Paul, I really appreciate you refining everything and teaching me in the process. Hopefully one of these days I'll be passing it on!

Donna

macropod · #7 03-07-2013, 12:05 AM

Hi Donna,

If you don't want to ensure the formatting consistency the above macro provides vis-a-vis the colons, the code can be reduced, but it's not clear whether you want to enforce two spaces or whether you're concerned with keeping the SSID/SSN strings on the same lines as the numbers to which they relate. The above code (give it a try) does this - even the hyphens are of the non-breaking kind.

dmarie123 · #8 03-07-2013, 10:12 AM

Hi Paul,

Quote:

If you don't want to ensure the formatting consistency the above macro provides vis-a-vis the colons, the code can be reduced, but it's not clear whether you want to enforce two spaces or whether you're concerned with keeping the SSID/SSN strings on the same lines as the numbers to which they relate. The above code (give it a try) does this - even the hyphens are of the non-breaking kind.

I do want to keep the two spaces and I also want the "labels" like 'SSN' to be on the same lines. I'm not sure I understand exactly what you mean. This is what I have so far:

Code:

Sub DirectoryFindReplace()
Application.ScreenUpdating = True
Dim strFolder As String, strFile As String, wdDoc As Document
Dim TrkStatus As Boolean, StrTxt As String, Rng As Range, RngTmp As Range
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="C:\Users\Macropod\Documents\Attachments\Temp\FindWords.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
 
  ' 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)
  With wdDoc
 
'Store the current change-tracking status
    'TrkStatus = .TrackRevisions
    'Ensure change-tracking is on
    '.TrackRevisions = True
 
    Set Rng = .Range(0, 0)
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .Wrap = wdFindContinue
 
        ' Process each word doc from the F/R List
        For i = 1 To UBound(Split(xlFList, "|"))
          .Text = Split(xlFList, "|")(i)
          .Replacement.Text = Split(xlRList, "|")(i)
          .Execute Replace:=wdReplaceAll
        Next
 
        'Update SSID, SNUM & Date range formatting
        .Wrap = wdFindStop
        .MatchWildcards = True
        .Replacement.Text = ""
 
        'Fix SSIDs
         End With
        .Start = Rng.Start
        .Collapse wdCollapseStart
        'First, work on unformatted TINs
      With .Find
        .Text = "SSID[: ^0160]{1,}[0-9]{9}>"
        .Execute
      End With
      Do While .Find.Found
        'Hyphenate the number with non-breaking hyphens
        .Start = .End - 7
        .End = .End - 3
        .InsertBefore "-"
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
           
      'Add enumerated to SNUM
      .Start = Rng.Start
      .Collapse wdCollapseStart
      With .Find
        .Text = "SNUM[: ^0160]{1,}[0-9]{10}>"
        .Execute
      End With
      Do While .Find.Found
           'Ensure there is provision for the approval date:
        Set RngTmp = .Characters.Last
        RngTmp.MoveEnd wdCharacter, 30
        If InStr(RngTmp, "Approved") = 0 Then
          .Collapse wdCollapseEnd
          .Text = " (Enumerated: DATE)"
        End If
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
       
    'Fix Date ranges
    .Start = Rng.Start
    .Collapse wdCollapseStart
    With .Find
    .Text = "[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}-[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}"
    .Execute
    End With
    Do While .Find.Found
    StrTxt = Format(Trim(Split(.Text, "-")(0)), "MMMM D, YYYY")
    Select Case Trim(LCase(.Words.First.Previous.Previous.Words.First))
      Case "between": StrTxt = StrTxt & " and "
      Case "from": StrTxt = StrTxt & " to "
      Case "of": StrTxt = StrTxt & " through "
    End Select
    StrTxt = StrTxt & Format(Trim(Split(.Text, "-")(1)), "MMMM D, YYYY")
    .Text = StrTxt
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
 
    'Restore the original change tracking status
    '.TrackRevisions = TrkStatus
    'Close & save the document
    .Close SaveChanges:=True
  End With
 
  'Get the next document
  strFile = Dir()
Wend
Set Rng = Nothing: Set RngTmp = 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 had to change the hyphen because it was putting in the long hyphen and I only needed the short one, I don't know the "chr" for that, or if there is one, so I just used "-". Somewhere along the way between our exchanges I was missing a part of the "fix date ranges" section so it wasn't converting the short dates to long dates, I was able to put that back in successfully (phew). The macro runs with the track changes code commented out but if I remove the apostrophes to activate the code then it spits back this line as out of range:

Code:

 StrTxt = Format(Trim(Split(.Text, "-")(0)), "MMMM D, YYYY")

At this point we may have gotten around the track changes but it's a matter of principal. Sometimes it will work and then other times it breaks down and I have to exit word and start fresh.

Thank you Paul!! I know I keep saying that but I'm learning so much, even if the code doesn't show it yet!
-Donna

macropod · #9 03-07-2013, 03:24 PM

Hi Donna,

OK, lets go through the issues one at a time:
1. Should there always a colon after SSN/SSID when it is followed by an SSN/SSID number?
2. Should there is always one space, or two spaces before the SSN/SSID number?
3. Should the space(s) between SSN/SSID and the SSN/SSID number be non-breaking, so as to ensure the SSN/SSID stays on the same line as its number number?
4. Should the hyphens within the SSN/SSID number be non-breaking, so as to ensure all parts of the SSN/SSID number stay on the same line?

At the moment, my code's answers to these questions is:
1. Yes
2. One space
3. Yes
4. Yes

If I understand what you're saying, your answers would be:
1. No. If there's a colon, leave it; if there isn't, don't add one.
2. ???
3. Yes
4. Yes

Re:

Quote:

I had to change the hyphen because it was putting in the long hyphen and I only needed the short one

The hyphen that was being inserted is the non-breaking kind. It is the same length as a normal one, but looks longer when Word is displaying formatting.

Chr(#) tell the code to use an ASCII character value. Chr(30) is a non-breaking hyphen and Chr(160) is a non-breaking space.

You asked:

Quote:

If I add an extra space inside the brackets will it do both a colon and two spaces?? That would be cleaner code-wise.

a Find expression like "SSN[: ^0160]{1,}[0-9]{9}>" will find SSN followed by at least one colon or space (breaking or non-breaking), then a 9-digit number. So, it will find 'SSN:123456789', 'SSN: 123456789', 'SSN 123456789', 'SSN 123456789', 'SSN: 123456789', etc, regardless of how many breaking or non-breaking spaces there are, provided there is at least one colon or a space between the SSN and its number.

You also asked:

Quote:

Also, where do I put the code to format the text to Arial, size 11, left-justified?

That depends on what it is you want to do that to. IMHO, though, it would be better to define a Style that way and apply the Style rather than overriding an existing Style's formatting.

As for:

Quote:

The macro runs with the track changes code commented out but if I remove the apostrophes to activate the code then it spits back this line as out of range:
...
At this point we may have gotten around the track changes but it's a matter of principal. Sometimes it will work and then other times it breaks down and I have to exit word and start fresh.

You're evidently still partially working with a previous iteration of the code and the mixing of the two versions might be behind the problem. In any event, my most recent version (above) is much 'smarter' in its processing of the dates.

dmarie123 · #10 03-08-2013, 09:06 AM

Hi Paul,

Regarding your questions:

Quote:

If I understand what you're saying, your answers would be:
1. No. If there's a colon, leave it; if there isn't, don't add one. --correct

2. ??? --In the documents that the macro searches each colon is followed by two spaces BUT when SSN/SSID appears in a sentence without a colon then it would just be one space.

3. Yes --correct

4. Yes -- correct

Your most recent version of the code is almost exactly what I want but it doesn't convert the dates to the longer format. How should I update the code to include the change from 11/12/2013 to November 12, 2013 and also include the above adjustments per your questions.

To further complicate things, the SSNs/SSIDs that appear with a colon are in a section of identifiers where the "SSN: 1234567899" is the only thing on the line so once I run the macro it would change the text like so:

From this:
Student Name
City: Chicago
SSID: 12345678999
SSN: 123456789

To this:
Student Name
City: Chicago
SSID: 12345678999 (Approved: )
SSN: 12-3456789

(You'll see there's a small change above with the hyphen now falling after the second digit, this was recently changed in our requirements, ugh.)

The rest of the SSIDs and SSNs that do not have a colon appear in the middle of paragraphs so regular spacing would apply.
By regular I mean if it happens to fall the way this one does ==> SSN
123456789 where the number is on the next line then that's acceptable, it's also acceptable to fall as SSN 123456789 in the middle of a sentence.

Is there a way around the hyphen displaying with formatting so it appears as the shorter one? Isn't that what the below does?

Code:

.ClearFormatting
        .Replacement.ClearFormatting

As far as applying the style I want to apply Arial 11, Left Aligned to all the documents in a folder because they come to us in variable fonts and sizes.

I'd MUCH rather use your most recent code (with the needed updates) but I wanted to at least attempt to resolve it on my own, I definitely don't mean to be one of the people that asks for help and then doesn't use it. I appreciate every single minute of your help.

Thank you,
Donna

macropod · #11 03-08-2013, 09:01 PM

Hi Donna,

I'm glad to see you're at least having a go. I much prefer to see people learning than simply waiting for solutions to be served up. As for '.ClearFormatting' and '.Replacement.ClearFormatting', these just tell the Find/Replace expression to clear out any references to Styles, font attributes etc, that might be lurking around from a previous Find/Replace. The have no effect at all on the display. You can toggle the display by clicking the ¶ symbol on the Ribbon. Whether you do this has no effect on the printout, though - you'll still get a short (non-breaking) hypen.

At this stage, I'd say the code really needs to be modularised, so that we can treat its various operations separately. Having everything thown together in a single sub (plus a couple of functions), doesn't aid legibility & maintenance. To that end, try:

Code:

Sub BulkFindReplace()
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, TrkStatus As Boolean, Rslt
StrWkBkNm = "C:\Users\Macropod\Documents\Attachments\Temp\FindWords.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
 
  ' 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)
 
  'Store the current change-tracking status
  TrkStatus = wdDoc.TrackRevisions
  'Ensure change-tracking is on
  wdDoc.TrackRevisions = True
 
  'Update the document
  Call ProcessFRList(wdDoc, xlFList, xlRList)
  Call ProcessSSNs(wdDoc)
  Call ProcessSSIDs(wdDoc)
  Call ProcessDates(wdDoc)
 
  'Restore the original change tracking status
  wdDoc.TrackRevisions = TrkStatus
  'Close & save the document
  wdDoc.Close SaveChanges:=True
  'Get the next document
  strFile = Dir()
Wend
Set Rng = Nothing: Set RngTmp = 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
 
Private Sub ProcessFRList(wdDoc As Document, xlFList As String, xlRList As String)
Dim i As Long
With wdDoc.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Forward = True
  .Format = False
  .MatchCase = True
  .MatchWholeWord = True
  .Wrap = wdFindContinue
 
  ' Process each word doc from the F/R List
  For i = 1 To UBound(Split(xlFList, "|"))
    .Text = Split(xlFList, "|")(i)
    .Replacement.Text = Split(xlRList, "|")(i)
    .Execute Replace:=wdReplaceAll
  Next
End With
End Sub
 
Private Sub ProcessSSNs(wdDoc As Document)
Dim RngTmp As Range
'Ensure SSNs are correctly formatted.
'In 'SSN: #', 'SSN:' is followed by two non-breaking spaces
'In 'SSN #', 'SSN' is followed by one non-breaking space.
'Both are then followed by the number in the ##-####-### format
'with non-breaking hypens
With wdDoc.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Format = False
    .MatchCase = True
    .MatchWholeWord = True
    .MatchWildcards = True
    .Wrap = wdFindStop
    .Text = "SSN[: ^0160]{1,}[0-9/-]{9,11}>"
    .Replacement.Text = ""
    .Execute
  End With
  Do While .Find.Found
    If Mid(.Text, 4, 1) = ":" Then
      'Ensure SSN followed by a colon is followed by two non-breaking spaces
      Set RngTmp = .Characters(5)
      With RngTmp
        Do Until IsNumeric(.Characters.Last.Next.Text) = True
          .MoveEnd wdCharacter, 1
        Loop
        If .Text <> Chr(160) & Chr(160) Then .Text = Chr(160) & Chr(160)
      End With
    Else
      'Ensure SSN not followed by a colon is followed by one non-breaking space
      Set RngTmp = .Characters(4)
      With RngTmp
        Do Until IsNumeric(.Characters.Last.Next.Text) = True
          .End = .End + 1
        Loop
        If .Text <> Chr(160) Then .Text = Chr(160)
      End With
    End If
    'Hypenate the number with non-breaking hyphens
    .Start = RngTmp.End
    If (InStr(.Text, "-") > 0 Or InStr(.Text, Chr(30)) > 0) Then
      If InStr(.Text, "-") = 3 Then
        Set RngTmp = .Characters(3)
        If RngTmp.Text = "-" Then
          RngTmp.Text = Chr(30)
        Else
          RngTmp.InsertBefore Chr(30)
        End If
      End If
      .Start = RngTmp.End
      If InStr(.Text, "-") = 4 Then
        Set RngTmp = .Characters(4)
        If RngTmp.Text = "-" Then
          RngTmp.Text = Chr(30)
        Else
          RngTmp.InsertBefore Chr(30)
        End If
      End If
    Else
      .Start = .End - 7
      .End = .End - 3
      .InsertAfter Chr(30)
      .InsertBefore Chr(30)
    End If
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
End Sub
 
Private Sub ProcessSSIDs(wdDoc As Document)
Dim RngTmp As Range
'Ensure SSIDs are correctly formatted.
'In 'SSID: #', 'SSID:' is followed by two non-breaking spaces
'In 'SSID #', 'SSID' is followed by one non-breaking space.
'Both are then followed by the number in the ##-######## format
'with non-breaking hypens
With wdDoc.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Format = False
    .MatchCase = True
    .MatchWholeWord = True
    .MatchWildcards = True
    .Wrap = wdFindStop
    .Text = "SSID[: ^0160]{1,}[0-9/-]{10,12}>"
    .Replacement.Text = ""
    .Execute
  End With
  Do While .Find.Found
    If Mid(.Text, 5, 1) = ":" Then
      'Ensure SSID followed by a colon is followed by two non-breaking spaces
      Set RngTmp = .Characters(6)
      With RngTmp
        Do Until IsNumeric(.Characters.Last.Next.Text) = True
          .MoveEnd wdCharacter, 1
        Loop
        If .Text <> Chr(160) & Chr(160) Then .Text = Chr(160) & Chr(160)
      End With
    Else
      'Ensure SSID not followed by a colon is followed by one non-breaking space
      Set RngTmp = .Characters(5)
      With RngTmp
        Do Until IsNumeric(.Characters.Last.Next.Text) = True
          .MoveEnd wdCharacter, 1
        Loop
        If .Text <> Chr(160) Then .Text = Chr(160)
      End With
    End If
    'Hypenate the number with non-breaking hyphens
    .Start = RngTmp.End
    If InStr(.Text, "-") = 3 Then
      Set RngTmp = .Characters(3)
      RngTmp.Text = Chr(30)
    Else
      .Start = .End - 8
      .InsertBefore Chr(30)
    End If
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
End Sub
 
Private Sub ProcessDates(wdDoc As Document)
Dim StrTxt As String
With wdDoc.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Format = False
    .MatchCase = True
    .MatchWholeWord = True
    .MatchWildcards = True
    .Wrap = wdFindStop
    .Text = "[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}-[0-9]{1,2}/[0-9]{1,2}/[0-9]{4}"
    .Replacement.Text = ""
    .Execute
  End With
  Do While .Find.Found
    StrTxt = Format(Trim(Split(.Text, "-")(0)), "MMMM D, YYYY")
    Select Case Trim(LCase(.Words.First.Previous.Previous.Words.First))
      Case "between": StrTxt = StrTxt & " and "
      Case "from": StrTxt = StrTxt & " to "
      Case "of": StrTxt = StrTxt & " through "
    End Select
    StrTxt = StrTxt & Format(Trim(Split(.Text, "-")(1)), "MMMM D, YYYY")
    .Text = StrTxt
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
End Sub

The above should, I think, address everything except the "Arial 11, Left Aligned" formatting. I'm still not sure what you want it applied to - some of the paragraphs the above code is modifying, or the document as a whole? If it's the latter, we could simply modify the Normal Style and apply that to the whole document. Everything in them would then become "Arial 11, Left Aligned" and about the only non-standard attributes that would remain are things like font super/sub-scripts, colouring, bold, underline & italics.

dmarie123 · #12 03-28-2013, 11:50 AM

Hi Paul,

Sorry I was away for so long, I was working on another project and also started school recently.

When I run the code above I get a "subscript out of range" error for the same line of code as before:

Code:

StrTxt = Format(Trim(Split(.Text, "-")(0)), "MMMM D, YYYY")

I'm at a loss, I've been working on it all day. Even my older version of this monster is now giving the error and before it worked fine. Any ideas?

-Donna

Is it possible that changing a reference in Access would affect MS Word?? I added a ref to Microsoft ActiveX Data Objects 2.5 Library for a module. Could that be the problem?

macropod · #13 03-28-2013, 07:19 PM

Hi Donna,

I can't reproduce that error. Can you attach a document to a post with some data the code fails with (delete anything sensitive)? You do this via the paperclip symbol on the 'Go Advanced' tab. Adding the reference is unlikely to have had any effect.

dmarie123 · #14 04-01-2013, 07:02 AM

Hi Paul,

Hope you had a lovely Easter

. I've attached a sample document that I get the "subscript out of range" error on. I've gone back to previous versions that we worked on and noticed that for whatever reason it doesn't change the date parameters preceded by "of". It will change the other versions but not that one. Could it be because the source document is being cut and pasted from and affecting the format? I know it's in the code already to clear it but something is preventing it from making the change.

Any input would be appreciated.

Thank you!
Donna

macropod · #15 04-01-2013, 04:00 PM

Hi Donna,

With the 'ProcessDates' sub, I didn't get an error message, but I did find that the code got stuck in a loop. That can be fixed by changing:
.Forward = True
and
.Collapse wdCollapseEnd
to:
.Forward = False
and
.Collapse wdCollapseStart

Also (unrelated), with the 'BulkFindReplace' sub, change the first:
Application.ScreenUpdating = True
to:
Application.ScreenUpdating = False

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Paste special an Excel range into Outlook as an Excel Worksheet	charlesh3	Excel Programming	3	02-04-2013 04:33 PM
Bad view when using Find and Find & Replace - Word places found string on top line	paulkaye	Word	4	12-06-2011 11:05 PM
Is there a way to use "find/replace" to find italics words?	slayda	Word	3	09-14-2011 02:16 PM
Help with find and replace or query and replace	shabbaranks	Excel	4	03-19-2011 08:38 AM
Find and Replace within range	anil3b2	Word VBA	3	12-01-2010 02:35 AM