Created
September 17, 2025 18:37
-
-
Save ChrisTitusTech/aa34a8757e3c3f1ccd1385f01548bbc8 to your computer and use it in GitHub Desktop.
Change All Track Changes / Comments to Single User
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Sub AcceptAndRecreateWorkingVersion() | |
| Dim doc As Document | |
| Dim rev As Revision | |
| Dim com As Comment | |
| Dim originalTrackChanges As Boolean | |
| Dim revCount As Long | |
| Dim response As VbMsgBoxResult | |
| Dim authors As Collection | |
| Dim author As Variant | |
| Dim sOldAuthor As String | |
| Dim sNewAuthor As String | |
| Dim sec As Section | |
| Dim hf As HeaderFooter | |
| Dim sWOOXML As String | |
| Dim sFindAuthor As String | |
| Dim sReplaceAuthor As String | |
| Dim hasChanges As Boolean | |
| Dim newAuthor As String | |
| 'Set Author Name Here | |
| newAuthor = "New Author" | |
| On Error GoTo ErrorHandler | |
| Set doc = ActiveDocument | |
| revCount = doc.Revisions.Count | |
| If revCount = 0 Then | |
| MsgBox "No tracked changes found.", vbInformation, "No Revisions" | |
| Exit Sub | |
| End If | |
| response = MsgBox("Set all tracked changes to '" & newAuthor & "' as author?" & vbNewLine & _ | |
| "Processes via XML for all types.", vbYesNo + vbQuestion, "Confirm") | |
| If response = vbNo Then Exit Sub | |
| ' Store settings | |
| originalTrackChanges = doc.TrackRevisions | |
| Application.ScreenUpdating = False | |
| ' Collect unique authors excluding newAuthor | |
| Set authors = New Collection | |
| hasChanges = False | |
| For Each rev In doc.Revisions | |
| If rev.Author <> newAuthor Then | |
| On Error Resume Next | |
| authors.Add rev.Author, rev.Author | |
| If Err.Number = 0 Then hasChanges = True | |
| On Error GoTo ErrorHandler | |
| End If | |
| Next rev | |
| For Each com In doc.Comments | |
| If com.Author <> newAuthor Then | |
| On Error Resume Next | |
| authors.Add com.Author, com.Author | |
| If Err.Number = 0 Then hasChanges = True | |
| On Error GoTo ErrorHandler | |
| End If | |
| Next com | |
| If Not hasChanges Then | |
| MsgBox "No changes to process.", vbInformation, "Complete" | |
| GoTo CleanUp | |
| End If | |
| ' Turn off track revisions | |
| doc.TrackRevisions = False | |
| sNewAuthor = newAuthor | |
| ' Process each unique author | |
| For Each author In authors | |
| sOldAuthor = author | |
| sFindAuthor = "w:author=""" & sOldAuthor & """" | |
| sReplaceAuthor = "w:author=""" & sNewAuthor & """" | |
| ' Main content | |
| sWOOXML = doc.Content.WordOpenXML | |
| sWOOXML = Replace(sWOOXML, sFindAuthor, sReplaceAuthor) | |
| doc.Content.InsertXML sWOOXML | |
| ' Headers and footers | |
| For Each sec In doc.Sections | |
| For Each hf In sec.Headers | |
| sWOOXML = hf.Range.WordOpenXML | |
| sWOOXML = Replace(sWOOXML, sFindAuthor, sReplaceAuthor) | |
| hf.Range.InsertXML sWOOXML | |
| Next hf | |
| For Each hf In sec.Footers | |
| sWOOXML = hf.Range.WordOpenXML | |
| sWOOXML = Replace(sWOOXML, sFindAuthor, sReplaceAuthor) | |
| hf.Range.InsertXML sWOOXML | |
| Next hf | |
| Next sec | |
| Next author | |
| doc.Save ' Save to register changes | |
| CleanUp: | |
| doc.TrackRevisions = originalTrackChanges | |
| Application.ScreenUpdating = True | |
| Application.StatusBar = "" | |
| MsgBox "Processed all changes. Remaining revisions: " & doc.Revisions.Count, vbInformation, "Complete" | |
| Exit Sub | |
| ErrorHandler: | |
| MsgBox "Error: " & Err.Description, vbCritical, "Error" | |
| Resume CleanUp | |
| End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment