Track Changes Word Author Macro

Chris Titus — Wed, 17 Sep 2025 00:00:00 +0000

This is a method for changing ALL the authors in Microsoft Word to a single author for comments and revisions.

Who is this for?

Businesses and Law Firms that need to change the author before sending changes to a client.

The Macro and How to Use

Open a New Module in Visual Basic in Word (Alt + F11)

From VB Editor, Create a new Module (Right-click Normal -> Insert -> Module)

Paste the following code into the Normal-Module1 (Code) Window Note: Big window on the right

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

Save and Return to Word

Open the document you want to apply this to and run the macro with Alt+F8

Note: You can also bind this to a button on your ribbon/taskbar

Just swaping authors with NO timestamp reset

This way is not as comprehensive but it does not reset the timestamp on the changes.

Sub ChangeCommentCreator()
 Dim I As Long
 Dim Novo As String
 Dim Corto As String
 If Selection.Comments.Count = 0 Then
 MsgBox "No comments in your selection!", vbInformation, "Alerta"
 Exit Sub
 End If
 Novo = InputBox("New author name?", "Alerta")
 Corto = InputBox("New author initials?", "Alerta")
 If Novo = "" Or Corto = "" Then
 MsgBox "The author name/initials can’t be empty.", vbInformation, "Alerta"
 Exit Sub
 End If
 With Selection
 For I = 1 To .Comments.Count
 .Comments(I).Author = Novo
 .Comments(I).Initial = Corto
 Next I
 End With
End Sub

Word on Chris Titus Tech | Tech Content Creator

Track Changes Word Author Macro

Who is this for?

The Macro and How to Use

Just swaping authors with NO timestamp reset