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.