查找与 MS Word 单元格中包含的评论相关的列 table
Find the column related to comments contained in a cell of a MS Word table
我有一个包含两列 table 的 Word 文档
第 1 列包含数字
第 2 列包含文本
用户对第2栏的文字进行评论(见图)。
我可以创建一个 table 将所有评论与 this code 放在一起。
如何根据评论的文本访问另一列的编号?
目前的结果是这样的:
我需要第一列中包含评论的文本旁边的数字。
我想有一个方法类似于:
oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber)
但访问 table 单元格 - 然后我可以引用同一行和第一列来获取第一列的内容?
以下是生成上述 table 的代码。请注意,代码没有考虑到对属于 table 单元格的文本进行的评论,这正是我正在寻找的内容。
Sub ExtractCommentsToNewDocument()
'=========================
'Macro created 2007 by Lene Fredborg, DocTools - www.thedoctools.com
'Revised October 2013 by Lene Fredborg: Date column added to extract
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'=========================
'The macro creates a new document
'and extracts all comments from the active document
'incl. metadata
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
Dim oDoc As Document
Dim oNewDoc As Document
Dim oTable As Table
Dim nCount As Long
Dim n As Long
Dim Title As String
Title = "Extract All Comments to New Document"
Set oDoc = ActiveDocument
nCount = ActiveDocument.Comments.Count
If nCount = 0 Then
MsgBox "The active document contains no comments.", vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract all comments to a new document?", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If
Application.ScreenUpdating = False
'Create a new document for the comments, base on Normal.dot
Set oNewDoc = Documents.Add
'Set to landscape
oNewDoc.PageSetup.Orientation = wdOrientLandscape
'Insert a 4-column table for the comments
With oNewDoc
.Content = ""
Set oTable = .Tables.Add _
(range:=Selection.range, _
NumRows:=nCount + 1, _
NumColumns:=5)
End With
'Insert info in header - change date format as you wish
oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).range.Text = _
"Comments extracted from: " & oDoc.FullName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With oNewDoc.Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With oNewDoc.Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Format the table appropriately
With oTable
.range.Style = wdStyleNormal
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 5
.Columns(2).PreferredWidth = 23
.Columns(3).PreferredWidth = 42
.Columns(4).PreferredWidth = 18
.Columns(5).PreferredWidth = 12
.Rows(1).HeadingFormat = True
End With
'Insert table headings
With oTable.Rows(1)
.range.Font.Bold = True
.Cells(1).range.Text = "Page"
.Cells(2).range.Text = "Code"
.Cells(3).range.Text = "Text"
.Cells(4).range.Text = "Interview"
.Cells(5).range.Text = "Date"
End With
'Get info from each comment from oDoc and insert in table
For n = 1 To nCount
With oTable.Rows(n + 1)
'Page number
.Cells(1).range.Text = _
oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber)
'The comment itself
.Cells(2).range.Text = oDoc.Comments(n).range.Text
'The text marked by the comment
.Cells(3).range.Text = oDoc.Comments(n).Scope
'The comment author
.Cells(4).range.Text = oDoc.Comments(n).Author
'The comment date in format dd-MMM-yyyy
.Cells(5).range.Text = Format(oDoc.Comments(n).Date, "dd-MMM-yyyy")
End With
Next n
Application.ScreenUpdating = True
Application.ScreenRefresh
oNewDoc.Activate
MsgBox nCount & " comments found. Finished creating comments document.", vbOKOnly, Title
ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
End Sub
之后:
.Cells(3).Range.Text = oDoc.Comments(n).Scope
插入:
If oDoc.Comments(n).Scope.Information(wdWithInTable) = True Then
If oDoc.Comments(n).Scope.Cells(1).ColumnIndex > 1 Then
.Cells(3).Range.InsertBefore Split(oDoc.Comments(n).Scope.Rows(1).Cells(1).Range.Text, vbCr)(0) & vbTab
End If
End If
我有一个包含两列 table 的 Word 文档
第 1 列包含数字
第 2 列包含文本
用户对第2栏的文字进行评论(见图)。
我可以创建一个 table 将所有评论与 this code 放在一起。
如何根据评论的文本访问另一列的编号?
目前的结果是这样的:
我想有一个方法类似于:
oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber)
但访问 table 单元格 - 然后我可以引用同一行和第一列来获取第一列的内容?
以下是生成上述 table 的代码。请注意,代码没有考虑到对属于 table 单元格的文本进行的评论,这正是我正在寻找的内容。
Sub ExtractCommentsToNewDocument()
'=========================
'Macro created 2007 by Lene Fredborg, DocTools - www.thedoctools.com
'Revised October 2013 by Lene Fredborg: Date column added to extract
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'=========================
'The macro creates a new document
'and extracts all comments from the active document
'incl. metadata
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
Dim oDoc As Document
Dim oNewDoc As Document
Dim oTable As Table
Dim nCount As Long
Dim n As Long
Dim Title As String
Title = "Extract All Comments to New Document"
Set oDoc = ActiveDocument
nCount = ActiveDocument.Comments.Count
If nCount = 0 Then
MsgBox "The active document contains no comments.", vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract all comments to a new document?", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If
Application.ScreenUpdating = False
'Create a new document for the comments, base on Normal.dot
Set oNewDoc = Documents.Add
'Set to landscape
oNewDoc.PageSetup.Orientation = wdOrientLandscape
'Insert a 4-column table for the comments
With oNewDoc
.Content = ""
Set oTable = .Tables.Add _
(range:=Selection.range, _
NumRows:=nCount + 1, _
NumColumns:=5)
End With
'Insert info in header - change date format as you wish
oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).range.Text = _
"Comments extracted from: " & oDoc.FullName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With oNewDoc.Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With oNewDoc.Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Format the table appropriately
With oTable
.range.Style = wdStyleNormal
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 5
.Columns(2).PreferredWidth = 23
.Columns(3).PreferredWidth = 42
.Columns(4).PreferredWidth = 18
.Columns(5).PreferredWidth = 12
.Rows(1).HeadingFormat = True
End With
'Insert table headings
With oTable.Rows(1)
.range.Font.Bold = True
.Cells(1).range.Text = "Page"
.Cells(2).range.Text = "Code"
.Cells(3).range.Text = "Text"
.Cells(4).range.Text = "Interview"
.Cells(5).range.Text = "Date"
End With
'Get info from each comment from oDoc and insert in table
For n = 1 To nCount
With oTable.Rows(n + 1)
'Page number
.Cells(1).range.Text = _
oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber)
'The comment itself
.Cells(2).range.Text = oDoc.Comments(n).range.Text
'The text marked by the comment
.Cells(3).range.Text = oDoc.Comments(n).Scope
'The comment author
.Cells(4).range.Text = oDoc.Comments(n).Author
'The comment date in format dd-MMM-yyyy
.Cells(5).range.Text = Format(oDoc.Comments(n).Date, "dd-MMM-yyyy")
End With
Next n
Application.ScreenUpdating = True
Application.ScreenRefresh
oNewDoc.Activate
MsgBox nCount & " comments found. Finished creating comments document.", vbOKOnly, Title
ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
End Sub
之后:
.Cells(3).Range.Text = oDoc.Comments(n).Scope
插入:
If oDoc.Comments(n).Scope.Information(wdWithInTable) = True Then
If oDoc.Comments(n).Scope.Cells(1).ColumnIndex > 1 Then
.Cells(3).Range.InsertBefore Split(oDoc.Comments(n).Scope.Rows(1).Cells(1).Range.Text, vbCr)(0) & vbTab
End If
End If