Hi there. I'm using the following coding and am wondering if it is possible to be able to only have the macro save the document if there was actually a change made to it? The user wants to use this macro to change any documents that contain a certain search term easily, but then wants to be able to identify exactly which documents were actually changed. Currently the code opens all the documents, does the search and replace, and then saves the document. The modified date on the document then changes to the current date and time and there is no way for me to identify which document was actually changed. Is this possible or is there a better way of doing this?
Thank you so much!!
Code:
Sub Loop_AllWordFiles_inFolder()
'macro created by Michelle Peters August 12, 2022
'Optimize Macro Speed
Application.ScreenUpdating = False
Dim strDocNm As String, strFolder As String, strFile As String, wdDoc As Document
Dim strFind As String, strRplc As String
Dim strWildCrd As Integer
'Have user enter the search and replace strings and if there are wildcards
strFind = InputBox("Enter your search string and use wildcards if necessary.")
strRplc = InputBox("Enter your replace string and use wildcards if necessary.")
strWildCrd = MsgBox("Do either your search or replace string contain wildcard characters?", vbQuestion + vbYesNo + vbDefaultButton2, "Wildcards")
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
strDocNm = ThisDocument.FullName
While strFile <> ""
If strFolder & " \ " & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & " \ " & strFile, AddToRecentFiles:=False, Visible:=True)
With wdDoc
Call FindReplaceAnywhere(wdDoc, strFind, strRplc, strWildCrd)
.Close SaveChanges:=True
End With
End If
strFile = Dir()
Wend
MsgBox "Finished scanning all files in Folder " & Path
Set wdDoc = 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
Sub FindReplaceAnywhere(wDoc As Document, ByVal strFind As String, ByVal strRplc As String, ByVal strWildCrd As Integer)
'macro created by Michelle Peters March 18, 2022
'macro created to loop through all stories in Word to replace text
Dim rngStory As Word.Range
Dim lngValidate As Long
Dim oShp As Shape
'Fix the skipped blank header/footer problem
lngValidate = wDoc.Sections(1).Headers(1).Range.StoryType
'Iterate through all stroy types in the current document
For Each rngStory In wDoc.StoryRanges
'Iterate through all linked stories
Do
If strWildCrd = vbYes Then
SearchandReplaceWild rngStory, strFind, strRplc
Else
SearchandReplaceInStory rngStory, strFind, strRplc
End If
On Error Resume Next
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
If strWildCrd = vbYes Then
SearchandReplaceWild oShp.TextFrame.TextRange, strFind, strRplc
Else
SearchandReplaceInStory oShp.TextFrame.TextRange, strFind, strRplc
End If
End If
Next
End If
Case Else
'do Nothing
End Select
On Error GoTo 0
'get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
wDoc.BuiltInDocumentProperties(wdPropertyComments) = strRplc
lbl_exit:
Exit Sub
End Sub
Sub SearchandReplaceInStory(ByVal rngStory As Word.Range, ByVal strSearch As String, ByVal strReplace As String)
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Wrap = wdFindContinue
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
End With
lbl_exit:
Exit Sub
End Sub
Sub SearchandReplaceWild(ByVal rngStory As Word.Range, ByVal strSearch As String, ByVal strReplace As String)
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Wrap = wdFindContinue
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
lbl_exit:
End Sub