我想复制Word中添加注释的段落并放入Excel表格中

Question

我在 LinkedIn 中发现了一个非常简单的宏，来自“Harriet”。 L'，查看 Word 文档中的注释并创建一个 Excel 表格，为文档中的每条注释播种“页面、作者、注释文本和创建日期”（请参阅底部的 VBA 代码）

效果非常好 - 但我还想抓取评论所在段落中的所有文本，以便在 Excel 表格中看到评论时有一些上下文。

有什么想法吗？？

Harriet 的 VBA 代码...

Sub ExportCommentsToExcel()
    Dim xlApp As Object, xlWB As Object
    Dim i As Integer
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlWB = xlApp.Workbooks.Add
    With xlWB.Worksheets(1)
        ' Set header values
        .Cells(1, 1).Value = "Page Number"
        .Cells(1, 2).Value = "Author's Name"
        .Cells(1, 3).Value = "Comment"
        .Cells(1, 4).Value = "Date"

        ' Format headers
        With .Range("A1:D1")
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
            .Interior.Color = RGB(191, 191, 191) ' Grey color
            .Borders.Weight = xlThin
            .Borders.LineStyle = xlContinuous
        End With

        ' Populate the data
        For i = 1 To ActiveDocument.Comments.Count
            .Cells(i + 1, 1).Value = ActiveDocument.Comments(i).Scope.Information(wdActiveEndPageNumber)
            .Cells(i + 1, 2).Value = ActiveDocument.Comments(i).Author
            .Cells(i + 1, 3).Value = ActiveDocument.Comments(i).Range.Text
            .Cells(i + 1, 4).Value = Format(ActiveDocument.Comments(i).Date, "dd/mm/yyyy")
        Next i

        ' AutoFit columns for responsiveness
        .Columns("A:D").AutoFit
    End With
    Set xlWB = Nothing
    Set xlApp = Nothing
End Sub

Answer 1

在您的

'Set header values

部分中，添加以下行：

.Cells(1, 5).Value = "Source Text"

在您的

'Populate the data

部分中，添加以下行：

.Cells(i + 1, 5).Value = ActiveDocument.Comments(i).Scope.Text

此处完全修改的代码：

Sub ExportCommentsToExcel()
    Dim xlApp As Object, xlWB As Object
    Dim i As Integer
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlWB = xlApp.Workbooks.Add
    With xlWB.Worksheets(1)
        ' Set header values
        .Cells(1, 1).Value = "Page Number"
        .Cells(1, 2).Value = "Author's Name"
        .Cells(1, 3).Value = "Comment"
        .Cells(1, 4).Value = "Date"
        .Cells(1, 5).Value = "Source Text"

        ' Format headers
        With .Range("A1:E1")
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
            .Interior.Color = RGB(191, 191, 191) ' Grey color
            .Borders.Weight = xlThin
            .Borders.LineStyle = xlContinuous
        End With

        ' Populate the data
        For i = 1 To ActiveDocument.Comments.Count
            .Cells(i + 1, 1).Value = ActiveDocument.Comments(i).Scope.Information(wdActiveEndPageNumber)
            .Cells(i + 1, 2).Value = ActiveDocument.Comments(i).Author
            .Cells(i + 1, 3).Value = ActiveDocument.Comments(i).Range.Text
            .Cells(i + 1, 4).Value = Format(ActiveDocument.Comments(i).Date, "dd/mm/yyyy")
            .Cells(i + 1, 5).Value = ActiveDocument.Comments(i).Scope.Text
        Next i

        ' AutoFit columns for responsiveness
        .Columns("A:E").AutoFit
    End With
    Set xlWB = Nothing
    Set xlApp = Nothing
End Sub

希望有帮助！如果这对您有用，请接受它作为正确答案 - 谢谢！