View Single Post
 
Old 03-08-2013, 09:01 PM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote