Question

我不是编码员，所以我试图通过整理一些VBA来改变我的方式，这样我就可以在MS Word中选择的跟踪变化中更改作者姓名。我为评论做了类似的事情，但希望通过跟踪更改来实现。如果有人可以帮我解决我做错的事情，那就太棒了！

这是我到目前为止的代码：

Sub ChangeTracksBySingleAuthor()

    Dim J As Integer
    Dim sAuthorname As String
    Dim sOrigAuthorname As String

    If Selection.Range.Revisions.Count = 0 Then
        MsgBox "No changes in your selection!", vbCritical + vbOKOnly, "Cannot perform action"
        Exit Sub
    End If

    sOrigAuthorname = InputBox("Author name to change", "Changes Author Name")        
    If sOrigAuthorname = "" Then End

    sAuthorname = InputBox("New author name", "Changes Author Name")        
    If sAuthorname = "" Then End

    With ActiveDocument
        For J = 1 To .Revisions.Count
            If .Revisions(J).Author = sOrigAuthorname Then                
                .Revisions(J).Author = sAuthorname
            End If
        Next J
    End With

End Sub

Answer 1

之后没有直接的方法可以使用VBA更改修订版的作者。您可以事先更改作者，也可以使用以下方法之一：

编辑Open XML

将文档另存为.docx文件。
然后使用7-zip等拉链工具打开文件。
导航到word\document.xml（或修订所在文档的任何部分，例如页眉，页脚，脚注，尾注......），右键单击并选择编辑 < / LI>
搜索并替换作者姓名并将更改的文件保存到zip包

使用Word Compare

以下方法使用Word compare将所有修订的作者设置为特定作者（但请注意，此方法会生成可能（稍微）与原始修订版本不同的全新修订版本）：

保存原始文档的副本，将其命名为V1，并拒绝其中的所有更改。
保存原始文档的另一个副本，将其命名为V2，并接受其中的所有更改。
在Word中打开V1＆gt;评论标签＆gt;比较＆gt;进行比较。
在“比较文档”对话框中，导航到并选择V1作为原始文档，然后选择V2作为修订文档;在“标签更改为”后键入所需的作者姓名;在“显示更改”后，选择“新建文档”，然后单击“确定”。

Answer 2

注意：这是一个非常老的问题，但这似乎是从谷歌搜索中得出的，并且没有人在这里或其他任何地方提供解决方案，所以我要添加我的。

我是从事各种编码工作的新手，但是学习起来非常快速/直观，作为我的第一个项目，我一直在解决这个问题。

我认为我有一个解决方案，该解决方案在概念上可以通过与特定作者进行所有修订，将它们存储在集合中，拒绝它们出现在选择内容中，更改用户名，然后将更改重新实现为对文档（从而与新作者创建新修订版）。这是我的代码，很遗憾，由于我的工作PC已将作者锁定为安全策略，因此我无法对其进行测试。如果您看到此消息，它会起作用，请告诉我。

Sub ChangeRevisionAuthor()

Dim sCurrentAuthor As String
Dim sOldAuthor As String
Dim sNewAuthor As String
Dim sRevision As String

Dim TCStatus As Boolean

Dim myRange As Range
Dim revRange As Range

Dim myRev As Revision

Dim cIns As New Collection
Dim cDel As New Collection

If Selection.Range.Revisions.Count = 0 Then
    MsgBox "No track-changes in your selection!", _
      vbCritical + vbOKOnly, "Cannot perform action"
    Exit Sub
End If

sOldAuthor = InputBox("Old author name?", _
  "Comments Old Author Name")
If sOldAuthor = "" Then End

sNewAuthor = InputBox("New author name?", _
  "Comments New Author Name")
If sNewAuthor = "" Then End


BCStatus = ActiveDocument.TrackRevisions
sCurrentAuthor = Application.UserName

ActiveDocument.TrackRevisions = True

Set myRange = Selection.Range


For Each myRev In myRange.Revisions

    If myRev.Author = sOldAuthor Then
        If myRev.Type = wdRevisionInsert Then
        cIns.Add myRev
        End If
        If myRev.Type = wdRevisionDelete Then
        cDel.Add myRev
        End If
    End If

Next

Application.UserName = sNewAuthor

For Each myRev In cIns
    Set revRange = myRev.Range
    myText = revRange.Text
    myRev.Reject
    revRange.InsertAfter myText
Next

For Each myRev In cDel
    Set revRange = myRev.Range
    myRev.Reject
    revRange.Delete
Next

Application.UserName = sCurrentAuthor
ActiveDocument.TrackRevisions = BCStatus

End Sub

Answer 3

@ DirkVollmar帖子中描述的编辑Open XML 过程可以在VBA中可靠地自动化。与仅仅使用Word对象模型更改使用Word对象模型进行修订的作者的名称相比，这是大量工作，这自然根本不起作用。最后，一旦你开始工作，你肯定会获得编码器状态。

正如@DirkVollmar所建议的，7-Zip是我首选的与VBA一起使用的压缩工具。它是免费的，易于自动化，.dotx文件不需要重命名，并且您可以选择性地提取各种XML文件而无需解压缩整个事物。有关自动化7-Zip的更多信息，请参阅https://www.rondebruin.nl/win/s7/win004.htm。请务必解压缩标准Microsoft位置中的文件。
XML文件位于 UTF-8 中。 VBA不直接支持UTF-8，但在使用ADO读取时工作正常。一旦你有一个重音字符，西里尔字母或汉字作为作者，这将变得清晰。有关阅读UTF-8字符串的详细信息，请参阅https://www.mrexcel.com/forum/excel-questions/863606-import-text-file-utf-8-a.html。
读入后，可以使用库存VBA字符串函数（如InStr（），Replace（），Mid（）等）操作XML字符串。请注意，VBA IDE不支持扩展字符串的 display ，但这并不意味着它们不存在。只是不要指望在即时窗口看到汉字。
在XML字符串中，查找author =并在之后立即替换带引号的字符串，即author =“Autor”之类的内容变为author =“Fritz”。
要完成，请使用ADO将文件写回临时目录，然后使用7-Zip自动将它们放回原始的.dotx文件中。确保在.dotx文件中更换临时文件后删除（Kill函数）临时文件。

请确保在开发过程中备份.dotx文件，因为您肯定会创建Word无法读取并声称“已损坏”的文件。话虽如此，一旦我开始工作，我从来没有设法破坏.dotx使得Word无法读取它。

Answer 4

这里是一个宏，用于根据Word文档（docx，docm，dotx或dotm）中跟踪的更改和注释来更改作者姓名。该宏适用于最个跟踪的更改。它不会更改目录等更新字段上的作者姓名。

该宏会搜索整个文档，而不是整个选择，因此它不能完美地回答@ h2whoa中的问题。

致谢：@ dirk-vollmar建议编辑构成Word文档的xml文件。 @ v-v-kozlov建议在宏中使用Stream object进行编辑。 Jamie Garroch建议使用Windows Shell将文件移入或移出zip存档。

Sub ChangeTheAuthorOfTrackedChanges()
'Changes an author name on comments and tracked changes in a Word document.
'Requires a reference to the Microsoft ActiveX Data Objects 6.1 Library.

    Dim objFile As Object, objShell As Object, objStream As Object
    Dim strFullName, strTempPath, strFile, strDefault
    Dim strNames, strOldAuthor, strOldInitials, strNewAuthor, strNewInitials
    Dim strOldContent, strNewContent, strFind, strReplace, varTime
    On Error Resume Next

''=> To enter the file name and author name in the code, instead of input boxes,
''=> uncomment and edit these lines. Comment out the Ask1 and Ask2 sections.
'    strFullName = _
'        "C:\Users\Example\Desktop\Example - Copy.docx"
'    strOldAuthor = "John X. Doe"
'    strOldInitials = "JXD"
'    strNewAuthor = "Roe, Jane"
'    strNewInitials = "JR"

    'Asks for a file name.
    strDefault = "C:\Users\Example\Desktop\Example - Copy.docx"
Ask1:
    strFullName = InputBox(Prompt:="1. (Recommended) Save a copy of the " & _
        "document before running this macro." & vbCrLf & vbCrLf & _
        "2. Close the document before running this macro." & vbCrLf & vbCrLf & _
        "3. Type the file path and name of the document.", _
        Title:="Word document to change", _
        Default:=strDefault)
    'Warns and quits when a file name wasn't entered.
    If strFullName = strDefault Or strFullName = "" Then
        MsgBox Prompt:=vbCrLf & "A file name wasn't entered. The macro quit.", _
            Buttons:=vbExclamation
        Exit Sub
    End If
    'Warns and quits when a file is open.
    Set objFile = Nothing
    Set objFile = Documents(strFullName)
    If Not objFile Is Nothing Then
        MsgBox Prompt:=vbCrLf & "The document is open." & vbCrLf & vbCrLf & _
            "Close the document before running the macro.", _
            Buttons:=vbExclamation
        Set objFile = Nothing
        Exit Sub
    End If
    'Warns when a file isn't a Word file.
    If Right(strFullName, 5) <> ".docx" And _
        Right(strFullName, 5) <> ".docm" And _
        Right(strFullName, 5) <> ".dotx" And _
        Right(strFullName, 5) <> ".dotm" Then
        MsgBox Prompt:="The file name doesn't have a Word file extension" & _
            vbCrLf & "(docx, docm, dotx, or dotm)." & vbCrLf & vbCrLf & _
            "Check the file path and name.", _
            Buttons:=vbExclamation
            strDefault = strFullName
        GoTo Ask1:
    End If
    'Warns when a file doesn't exist.
    If Dir(strFullName, vbDirectory) = vbNullString Then
        MsgBox Prompt:=vbCrLf & "The document wasn't found." & vbCrLf & vbCrLf _
            & "Check the file path and name.", _
            Buttons:=vbExclamation
            strDefault = strFullName
        GoTo Ask1:
    End If

    'Asks for an author name to change.
    strDefault = "old name\old initials\new name\new initials"
Ask2:
    strNames = InputBox(Prompt:="Type the name and initials to change," & _
        vbCrLf & "separated by backslashes." & vbCrLf & vbCrLf & _
        "For example," & vbCrLf & "John X. Doe\JXD\Roe, Jane\JR", _
        Title:="Name and initials to change", _
        Default:=strDefault)
    'Warns and quits when an author name wasn't entered.
    If strNames = strDefault Or strNames = "" Then
        MsgBox Prompt:=vbCrLf & "Names weren't entered. The macro quit.", _
            Buttons:=vbExclamation
        Exit Sub
    End If
    'Divides the entered text.
    strDefault = strNames
    strOldAuthor = Left(strNames, InStr(strNames, "\") - 1)
        strNames = Mid(strNames, InStr(strNames, "\") + 1)
    strOldInitials = Left(strNames, InStr(strNames, "\") - 1)
        strNames = Mid(strNames, InStr(strNames, "\") + 1)
    strNewAuthor = Left(strNames, InStr(strNames, "\") - 1)
    strNewInitials = Mid(strNames, InStr(strNames, "\") + 1)
    'Warns when information is missing or too many backslashes are entered.
    If strOldAuthor = "" Or strOldInitials = "" Or strNewAuthor = "" Or _
        strNewInitials = "" Or InStr(strNewInitials, "\") <> 0 Then
        MsgBox Prompt:=vbCrLf & "Author names and initials weren't readable." _
            & vbCrLf & vbCrLf & "Check the author names, initials, and " & _
            "separator (\).", _
            Buttons:=vbExclamation
        GoTo Ask2:
        Exit Sub
    End If

    'Defines a temporary folder and expands some strings.
    strTempPath = Left(strFullName, InStrRev(strFullName, "\")) & Left(Rnd(), 5)
    strOldAuthor = "author=""" & strOldAuthor & """"
    strOldInitials = "initials=""" & strOldInitials & """"
    strNewAuthor = "author=""" & strNewAuthor & """"
    strNewInitials = "initials=""" & strNewInitials & """"

    'Opens the shell and stream objects. Sets some properties.
    Set objShell = CreateObject("Shell.Application")
    Set objStream = New ADODB.Stream
    objStream.Charset = "utf-8"
    objStream.Type = adTypeText

    'Renames the Word document as a zip file and moves the folder "\word".
    Name strFullName As (strFullName & ".zip")
    MkDir strTempPath
    objShell.NameSpace(strTempPath).MoveHere (strFullName & ".zip\word")

    strFile = "First time"
    Do
        'Gets the next file name in the folder "\word" using the Dir function.
        If strFile = "First time" Then
            strFile = Dir(strTempPath & "\word\")
        Else
            strFile = Dir
        End If

        If strFile <> "" Then
            'Opens a file and copies its content.
            With objStream
                .Open
                .LoadFromFile (strTempPath & "\word\" & strFile)
                strOldContent = .ReadText
            End With
                strNewContent = strOldContent

            'Replaces author and initials.
            strFind = strOldAuthor
            strReplace = strNewAuthor
            strNewContent = Replace(strNewContent, strFind, strReplace)
            strFind = strOldInitials
            strReplace = strNewInitials
            strNewContent = Replace(strNewContent, strFind, strReplace)

            'Saves the new content, if the content changed.
            If strNewContent <> strOldContent Then
                With objStream
                    .Position = 0
                    .WriteText strNewContent
                    .SetEOS
                    .SaveToFile (strTempPath & "\word\" & strFile), _
                        adSaveCreateOverWrite
                    .Close
                End With
            Else
                objStream.Close
            End If
        End If

    'Stops looping when the Dir function doesn't return a file name.
    Loop While strFile <> ""

    'Moves the folder "\word" into the zip file.
    objShell.NameSpace(strFullName & ".zip").MoveHere (strTempPath & "\word")

    'Delays for a few seconds, then renames the zip file as a Word file.
    varTime = Time + 0.0001
    Do
        DoEvents
    Loop Until Time >= varTime
    Name (strFullName & ".zip") As strFullName
    RmDir strTempPath

    MsgBox Prompt:="The macro searched and replaced.", Buttons:=vbInformation
    Set objShell = Nothing
    Set objStream = Nothing
End Sub

Answer 5

找到替换审阅者最初的唯一宏！！！

Sub ChangeCommentAuthor（）

Dim J As Integer

Dim rNameFind As String
Dim rNameRePlace As String


rNameFind = InputBox("Enter the Reviwer Name to Find", vbOK)
rNameRePlace = InputBox("Enter the Reviwer name  to Replace", vbOK)

If (rNameFind = "") Then
MsgBox "Input Reviwer Name to find is empty"
Exit Sub
End If

If (rNameRePlace = "") Then
MsgBox "Input Reviwer Name to replace is empty"
Exit Sub
End If

For J = 1 To 3

For i = 1 To ActiveDocument.Comments.Count

Dim objComment As Comment: Dim oInitial As String
If InStr(1, ActiveDocument.Comments(i).Initial, "") > 0 Then
oInitial = Replace(ActiveDocument.Comments(i).Initial, rNameFind, rNameRePlace)
Set objComment = ActiveDocument.Comments(i)
    objComment.Initial = oInitial

End If

Next i

Next J

结束子

Answer 6

最简单的方法

将文档另存为xml
使用记事本++打开
用New替换旧文本（作者姓名）。
保存xml
使用Word打开xml并以您喜欢的任何格式（.docx）保存

VBA更改Word中跟踪更改的作者姓名

6 个答案:

编辑Open XML

使用Word Compare