Track Changes Word Author Macro

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

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