#1
|
|||
|
|||
Find and Replace using Excel range
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 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 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 |
#2
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
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!!
|
#4
|
|||
|
|||
adding code, not working
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 3: Code:
'Add to Student ID .Text = "SID[:][ ][ ]{1,2}[0-9]{10}" .Replacement.Text = "^& (Approved: / / )" .Execute Replace:=wdReplaceAll 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 -Donna |
#5
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#6
|
|||
|
|||
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 |
#7
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#8
|
|||
|
|||
Uupdated - I tried
Hi Paul,
Quote:
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 Code:
StrTxt = Format(Trim(Split(.Text, "-")(0)), "MMMM D, YYYY") 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 |
#9
|
||||
|
||||
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:
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:
You also asked: Quote:
As for: Quote:
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#10
|
|||
|
|||
Hi Paul,
Regarding your questions: Quote:
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 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 Last edited by dmarie123; 03-08-2013 at 04:13 PM. |
#11
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#12
|
|||
|
|||
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") -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? |
#13
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#14
|
|||
|
|||
Sample Error Document
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 |
#15
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
Tags |
excel 2007, find and replace, vba in microsoft word |
|
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 |