从 excel 更新书签

Question

我在 VBA word 中有以下代码

• 选择excel文件
• 使用 Excel 单元格值中的值更新 word 中书签的值

一切正常，但不是使用 col B 上的值更新 colA 中的书签，而是代码仅插入书签。

    Function FileOpenDialogBox()

'Display a Dialog Box that allows to select a single file.
'The path for the file picked will be stored in fullpath variable
  With Application.FileDialog(msoFileDialogFilePicker)
        'Makes sure the user can select only one file
        .AllowMultiSelect = False
        'Filter to just the following types of files to narrow down selection options
        .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
        'Show the dialog box
        .Show
        
        'Store in fullpath variable
        fullpath = .SelectedItems.Item(1)
        FileOpenDialogBox = fullpath
    End With
'MsgBox FileOpenDialogBox
End Function

 
Sub WorkOnAWorkbook()

Dim oXL As Excel.Application
Dim oWB As Excel.Workbook
Dim oSheet As Excel.Worksheet
Dim oRng As Excel.Range
Dim ExcelWasNotRunning As Boolean
Dim WorkbookToWorkOn As String, msg1 As String
Dim val1, val2 As String
'specify the workbook to work on
WorkbookToWorkOn = FileOpenDialogBox

'If Excel is running, get a handle on it; otherwise start a new instance of Excel
On Error Resume Next
Set oXL = GetObject(, "Excel.Application")

If Err Then
   ExcelWasNotRunning = True
   Set oXL = New Excel.Application
End If

On Error GoTo Err_Handler

'If you want Excel to be visible, you could add the line: oXL.Visible = True here; but your code will run faster if you don't make it visible

'Open the workbook
Set oWB = oXL.Workbooks.Open(FileName:=WorkbookToWorkOn)

'Process each of the spreadsheets in the workbook
For Each oSheet In oXL.ActiveWorkbook.Worksheets
           'put guts of your code here
          ' msg = msg & oSheet.Range("A1").Value
        
           If oSheet.Name = "Sheet1" Then
                             lastrow = oSheet.Cells(oSheet.Rows.Count, "A").End(xlUp).Row
                  For i = 1 To lastrow
'                    MsgBox "last used row in col  A is " & lastrow
                     val1 = oSheet.Range("A" & i).Value 'value of the bookmark
                     val2 = oSheet.Range("B" & i).Value
                         
                              ActiveDocument.Bookmarks.Add Name:=val1, Range:=Selection.Range
                             'update bookmark if bookmark exists
                            If ActiveDocument.Bookmarks.Exists(val1) = True Then
                                    UpdateBookmark (val1), (val2)
                                    'MsgBox i
                                    j = j + 1 'counts number of bookmarks updated
                            ElseIf ActiveDocument.Bookmarks.Exists(val1) = False Then
                                    k = k + 1 'gives total of bookmarks not found
                            End If

                  Next i
           End If
           'get next sheet
Next oSheet
'Exit Sub
'MsgBox msg, , msg1
If ExcelWasNotRunning Then
  oXL.Quit
End If
 'Make sure you release object references.
Set oRng = Nothing
Set oSheet = Nothing
Set oWB = Nothing
Set oXL = Nothing

'quit
Call update_all_bookmarks 'update all bookmarks

MsgBox j & " Bookmarks updated!."
Exit Sub

Err_Handler:
   MsgBox WorkbookToWorkOn & " caused a problem. " & vbNewLine & Err.Description, vbCritical, _
           "Error: " & Err.Number
   If ExcelWasNotRunning Then
       oXL.Quit
   End If

End Sub
 

Sub UpdateBookmark(BookmarkToUpdate As String, TextToUse As String)
    Dim BMRange As Range
    Set BMRange = ActiveDocument.Bookmarks(BookmarkToUpdate).Range
    BMRange.Text = TextToUse
    'ActiveDocument.Bookmarks.Add BookmarkToUpdate, BMRange
End Sub
 

 Sub update_all_bookmarks()
' select the document and update the macro
    With Selection
        .WholeStory
        .Fields.Update
        .MoveLeft Unit:=wdCharacter, Count:=1
    End With
End Sub
Option Explicit
Sub RightClickMenu()
    Dim MenuButton As CommandBarButton
    With CommandBars("Text")
        Set MenuButton = .Controls.Add(msoControlButton)
        With MenuButton
            .Caption = "Update from excel"
            .Style = msoButtonCaption
            .OnAction = "WorkOnAWorkbook"
        End With
    End With
End Sub
 Sub ResetRightClick()
    Application.CommandBars("Text").Reset
End Sub

下面进入我的文档

Private Sub Document_Close()
ResetRightClick
End Sub

 
Private Sub Document_Open()
Call RightClickMenu
End Sub

任何帮助将不胜感激

Answer 1

未经测试，但应该或多或少是您需要做的：

Option Explicit

Sub UpdateBookmarksFromExcelFile()

    Dim oXL As Excel.Application
    Dim oWB As Excel.Workbook
    Dim oSheet As Excel.Worksheet
    Dim oRng As Excel.Range
    Dim ExcelWasNotRunning As Boolean
    Dim WorkbookToWorkOn As String, msg1 As String
    Dim bkmk As String, txt As String, doc As Document, i As Long, j As Long, k As Long
    
    WorkbookToWorkOn = FileOpenDialogBox 'specify the workbook to work on
    
    On Error Resume Next
    Set oXL = GetObject(, "Excel.Application")
    On Error GoTo 0
    If oXL Is Nothing Then
       ExcelWasNotRunning = True
       Set oXL = New Excel.Application
    End If

    On Error GoTo Err_Handler
    
    Set doc = ActiveDocument
    Set oWB = oXL.Workbooks.Open(FileName:=WorkbookToWorkOn)
    
    For Each oSheet In oWB.Worksheets
        If oSheet.Name = "Sheet1" Then
            For i = 1 To oSheet.Cells(oSheet.Rows.Count, "A").End(xlUp).Row
              
                bkmk = oSheet.Range("A" & i).Value 'value of the bookmark
                txt = oSheet.Range("B" & i).Value
                   
                If Len(bkmk) > 0 Then
                    If UpdateBookmark(doc, bkmk, txt) Then
                        j = j + 1 'counts number of bookmarks updated
                    Else
                        k = k + 1 'gives total of bookmarks not found
                    End If
                End If
            Next i
        End If
        
    Next oSheet

    oWB.Close False
    If ExcelWasNotRunning Then oXL.Quit

    MsgBox j & " Bookmarks updated, " & k & " Bookmarks not found."
Exit Sub

Err_Handler:
   MsgBox WorkbookToWorkOn & " caused a problem. " & vbNewLine & Err.Description, vbCritical, _
           "Error: " & Err.Number
   If ExcelWasNotRunning Then oXL.Quit
   
End Sub
 
'replace any text in a bookmark in doc with the supplied text: return True if successful
Function UpdateBookmark(doc As Document, BookmarkToUpdate As String, TextToUse As String) As Boolean
    Dim BMRange As Range
    If doc.Bookmarks.Exists(BookmarkToUpdate) Then
        Set BMRange = doc.Bookmarks(BookmarkToUpdate).Range
        BMRange.Text = TextToUse
        doc.Bookmarks.Add BookmarkToUpdate, BMRange
        UpdateBookmark = True
    Else
        UpdateBookmark = False 'no update
    End If
End Function