DataWright Information Services

Consulting and Resources for Excel and Access

Code for Word Bookmark Article

code is provided as a single source for pasting into a code module
behind a Word document. The descrption of the code can be found in
this article.

Sub RefreshAllTables()
''Purpose: To refresh the current table in a Word document with new data from
'' the corresponding range in an Excel document.
''The code uses bookmarks in the Word document and corresponding named ranges in 
'' Excel. The Excel data is brought in as pictures. This has the advantage that any 
'' formatting in the Excel document is retained, and the dimensions don't change 
'' significantly.
'' Also, bookmarks are simpler to create and maintain because a picture is only a 
'' single character in a Word document. 
''Requires: A table in the Excel file to line up the bookmarks and named ranges
''Created: 23 Oct 2008 by Denis Wright
    Dim objExcel As Object, _
        objWbk As Object, _
        objDoc As Document
    Dim sBookmark As String, _
        sWbkName As String
    Dim sRange As String, _
        sSheet As String
    Dim BMRange As Range
    Dim bmk As Bookmark
    Dim i As Integer, _
        j As Integer, _
        k As Integer, _
        bmkCount As Integer
    Dim vNames()
    Dim vBookmarks()
    Dim dlgOpen As FileDialog
    Dim bnExcel As Boolean
    On Error GoTo Err_Handle
    Set dlgOpen = Application.FileDialog( _
    bnExcel = False
    Do Until bnExcel = True
        With dlgOpen
            .AllowMultiSelect = True
            If .SelectedItems.Count > 0 Then
                sWbkName = .SelectedItems(1)
                MsgBox "Please select a workbook to use for processing"
            End If
        End With
        If InStr(1, sWbkName, ".xls") > 0 Then
            bnExcel = True
            MsgBox "The file must be a valid Excel file. Try again please..."
        End If
    Set objDoc = ActiveDocument
    'check to see that the Excel file is open. If not, open the file
    'also grab the wbk name to enable switching
    Set objExcel = GetObject(, "Excel.Application")
    For i = 1 To objExcel.Workbooks.Count
        If objExcel.Workbooks(i).Name = sWbkName Then
            Set objWbk = objExcel.Workbooks(i)
            Exit For
        End If
    If objWbk Is Nothing Then
        Set objWbk = objExcel.Workbooks.Open(sWbkName)
    End If
    'minimize the Excel window
    objExcel.WindowState = -4140 'minimized
    'switch to Excel, find range name that corresponds to the bookmark
    objExcel.Visible = False
    vNames = objWbk.Worksheets("Lists").Range("Bookmarks").Value
    'loop through the bookmarks
    bmkCount = ActiveDocument.Bookmarks.Count
    ReDim vBookmarks(bmkCount - 1)
    j = LBound(vBookmarks)
    For Each bmk In ActiveDocument.Bookmarks
        vBookmarks(j) = bmk.Name
        j = j + 1
    Next bmk
    For j = LBound(vBookmarks) To UBound(vBookmarks)
        'go to the bookmark
        Selection.GoTo What:=wdGoToBookmark, Name:=vBookmarks(j)
        Set BMRange = ActiveDocument.Bookmarks(vBookmarks(j)).Range
        For k = 1 To UBound(vNames)
            If vNames(k, 1) = vBookmarks(j) Then
                sSheet = vNames(k, 2)
                sRange = vNames(k, 3)
                Exit For
            End If
        Next k
        'copy data from the range as a picture
        objWbk.Worksheets(sSheet).Range(sRange).CopyPicture 1, -4147
        'return to Word and paste
        'Note: only required if the bookmark encloses a picture.
        'If the bmk held text, deleting the selection removes the bmk too.
        'Under those circumstances the code throws an error.
        'Clunky workaround: tell Word to ignore the error
        On Error Resume Next
        On Error GoTo 0
        'paste the picture, then move back one character so the new bookmark
        'encloses the pasted picture
        Selection.PasteAndFormat (wdPasteDefault)
        Selection.Move Unit:=wdCharacter, Count:=-1
        'now reinstate the bookmark
        objDoc.Bookmarks.Add Name:=vBookmarks(j), Range:=Selection.Range
    Next j
    'clean up
    Set BMRange = Nothing
    Set objWbk = Nothing
    objExcel.Visible = True
    Set objExcel = Nothing
    Set objDoc = Nothing
    MsgBox "The document has been updated"
    If Err.Number = 429 Then 'excel not running; launch Excel
        Set objExcel = CreateObject("Excel.Application")
        Resume Next
    ElseIf Err.Number <> 0 Then
        MsgBox "Error " & Err.Number & ": " & Err.Description
        Resume Err_Exit
    End If
End Sub