Code for Word Bookmark Article
This
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( _ FileDialogType:=msoFileDialogOpen) bnExcel = False Do Until bnExcel = True With dlgOpen .AllowMultiSelect = True .Show If .SelectedItems.Count > 0 Then sWbkName = .SelectedItems(1) Else MsgBox "Please select a workbook to use for processing" End If End With If InStr(1, sWbkName, ".xls") > 0 Then 'proceed bnExcel = True Else MsgBox "The file must be a valid Excel file. Try again please..." End If Loop 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 Next 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 objWbk.Activate 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 objDoc.Activate BMRange.Select Selection.Delete '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 ActiveDocument.Bookmarks(sBookmark).Delete 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 Err_Exit: 'clean up Set BMRange = Nothing Set objWbk = Nothing objExcel.Visible = True Set objExcel = Nothing Set objDoc = Nothing MsgBox "The document has been updated" Err_Handle: 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