如何从excel中打开word，并定位到指定的批注上

现在我想实现的是  
  已知：word文档的名字和其中一个批注的内容
  
  期望：
      在excel中的vba脚本，打开这个word文档，并找到这个批注，同时将批注所在页显示为当前页

请各位大侠多出援手  

谢谢
 

5 个解决方案

#1

无法解决效率问题，好多Comment怎么办

#2

只能一个个循环...

#3

以前实现过，这是整个文档中的一部分，使用正确，供参考。
注：在N1:N3区域中存放注释信息的文档名称

'查看批注主程序，找到批注所在段落位置
Sub FindCommentPosition()
    
    Dim SummaryReviewFile As Object
    Dim MyPath
    Dim PathName, shCMD As String
    Dim pos1 As Integer
    Dim tempStr As String
        
    
    '过滤PDM/.C/.CPP/.H文件
    If InStr(1, UCase(ActiveSheet.Cells(ActiveCell.Row, cnstColumnZ).Value), ".C") <> 0 _
       Or InStr(1, UCase(ActiveSheet.Cells(ActiveCell.Row, cnstColumnZ).Value), ".H") <> 0 _
       Or InStr(1, UCase(ActiveSheet.Cells(ActiveCell.Row, cnstColumnZ).Value), ".CSV") <> 0 Then
       
        MsgBox "来自CodeReview的检视信息不能在ReviewTool中查看批注", vbCritical, Title:="系统提示："
        Exit Sub
    End If
    
    
    '过滤不合法的表单
    If ActiveCell.Row < TotalDefectTblBgnRow _
       Or ActiveSheet.Cells(ActiveCell.Row, cnstColumnZ).Value = "" Then
         
        MsgBox "您选择跳转的单元无效,要求在数据区且含有数据！", vbCritical, "系统提示："
        Exit Sub
    End If
    
    On Error Resume Next
    
    PathName = ActiveWorkbook.FullName
    
   
    If InStr(1, UCase(ActiveSheet.Cells(ActiveCell.Row, cnstColumnZ).Value), ".DOC", vbTextCompare) <> 0 Then  '如果该文件名带有后缀".doc"
        tempStr = StrReverse(ActiveSheet.Range("N1").Value)
        pos1 = InStr(1, tempStr, "\", vbTextCompare)
        tempStr = StrReverse(Left(tempStr, pos1 - 1))
    End If
    
    If InStr(1, UCase(ActiveSheet.Cells(ActiveCell.Row, cnstColumnZ).Value), ".XLS", vbTextCompare) <> 0 Then  '如果该文件名带有后缀".doc"
        tempStr = StrReverse(ActiveSheet.Range("N2").Value)
        pos1 = InStr(1, tempStr, "\", vbTextCompare)
        tempStr = StrReverse(Left(tempStr, pos1 - 1))
    End If
    
    If InStr(1, UCase(ActiveSheet.Cells(ActiveCell.Row, cnstColumnZ).Value), ".PPT", vbTextCompare) <> 0 Then  '如果该文件名带有后缀".doc"
        tempStr = StrReverse(ActiveSheet.Range("N3").Value)
        pos1 = InStr(1, tempStr, "\", vbTextCompare)
        tempStr = StrReverse(Left(tempStr, pos1 - 1))
    End If
        
    
    
    If ActiveSheet.Cells(ActiveCell.Row, 2).Value <> "" Then
        If tempStr <> "" Then  '直接从N1:N3区域中提取存放注释信息的文档名称
            fileToOpen = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - Len(ActiveWorkbook.Name)) + Trim(tempStr)
        Else  '直接从对应行尾部的信息中提取存放注释信息的文档名称
            fileToOpen = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - Len(ActiveWorkbook.Name)) + Trim(ActiveSheet.Cells(ActiveCell.Row, cnstColumnZ).Value)
        End If
    Else
        MsgBox "评审描述信息不能为空！", vbCritical, "系统提示"
    End If
    
    Set myfile = GetObject(fileToOpen)
    
     
    '判断文件是否存在
    If myfile.Name = "" Then
            msg = "请检查文件 [" & fileToOpen & "] 是否存在！"
            MsgBox prompt:=msg, Buttons:=vbOKOnly, Title:="无法查看批注"
            Exit Sub
    End If
    
    '如果打开文件异常出错，提示错误信息
 '   If Err Then
  '      MsgBox prompt:="错误信息：" & Error(Err.Number), Buttons:=vbOKOnly, Title:="文件操作错误提示"
 '       Err.Clear    ' 清除 Err 对象字段。
 '       Exit Sub
 '   End If
      
    
    Select Case TypeName(myfile)
        Case "Document"
            myfile.ActiveWindow.Visible = True
            For Each Item In myfile.Comments
                If Item.Scope.Start = ActiveSheet.Cells(ActiveCell.Row, cnstColumnY).Value Then
                    Item.Scope.paragraphs(1).Range.Select
                    Application.ActivateMicrosoftApp xlMicrosoftWord
                    Exit For
                End If
            Next
        Case "Workbook"
            ListLabel = ActiveSheet.Cells(ActiveCell.Row, 3).Value
            Windows(myfile.Name).Visible = True
            pos = InStr(1, ListLabel, "!", vbTextCompare)
            SelectSheet = Left(ListLabel, pos - 1)
            SelectCell = Right(ListLabel, Len(ListLabel) - pos)
            myfile.Sheets(SelectSheet).Activate
            ActiveSheet.Range(SelectCell).Select
            'Application.ActivateMicrosoftApp xlMicrosoftExcel
        Case "Presentation"
              pos1 = InStr(1, ActiveSheet.Cells(ActiveCell.Row, 3).Value, "(")
              pos = InStr(pos1, ActiveSheet.Cells(ActiveCell.Row, 3).Value, ":")
          
            If pos > 0 Then
                SelectSlide = Mid(ActiveSheet.Cells(ActiveCell.Row, 3).Value, pos1 + 1, pos - 1 - pos1)
                myfile.Application.Visible = msoTrue
                myfile.slides(SelectSlide).Select
                'Application.ActivateMicrosoftApp xlMicrosoftPowerPoint
            End If
    End Select
End Sub

#4

ms有点复杂...

#5

没遇到过这种情况.