(Solved) – VBA Code for Updating Various Work Bookmarks?

(solved)-–-vba-code-for-updating-various-work-bookmarks?

I am relatively new to VBA and have watched a fair few tutorial videos/read a couple blogs to start getting my head around it. I’ve tried to write/edit my first code for work using example code from this page https://www.datawright.com.au/other/word_bookbark_vba_code_sample.htm and also a couple of tutorial guides to edit it.

For a bit of background… I write a lot a reports using microsoft word (have a macro enabled template) and import data from Excel (also macro enabled models). I’ve placed various bookmarks in the report template to populate by “linking” to Excel using the below code (for pictures, it calls up a range and copys/pastes that range across as an image). Noting this code is stored as a macro button in Microsoft Word.

Code does work, however, it is long so I am wondering if anyone has any tips on condensing it or improvements?

Also, is anyone able to show me how I can opt out of running the marco? Currently I have it so it forces you to pick an Excel compatible document and you cannot exit out of the dialogue box until this is picked. I was thinking of using a MsgBox at the start of the code to get a user to confirm whether they want to proceed/not proceed with the process.

Appreciate any advice! Code is provided below.

Option Explicit

Sub Populate_Fields()

    Dim objExcel As Object, _
        objWbk As Object, _
        objDoc As Document

    Dim sWbkName As String

    Dim sBookmark As String, _
        sRange As String, _
        sSheet As String, _
        sType As String

    Dim i As Integer
    Dim vNames()
    Dim dlgOpen As FileDialog
    Dim bnExcel As Boolean
    Dim intCounter As Integer
    Dim blnCloseWorkbook As Boolean

    On Error GoTo Err_Handle

    Set objDoc = ActiveDocument

    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

    Application.ScreenUpdating = False
    blnCloseWorkbook = True

    '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 LCase(objExcel.workbooks(i).FullName) = LCase(sWbkName) Then
            Set objWbk = objExcel.workbooks(i)
            blnCloseWorkbook = False
            Exit For
        End If
    Next

    If objWbk Is Nothing Then
        Set objWbk = objExcel.workbooks.Open(sWbkName)
    End If

    'switch to Excel, find range name that corresponds to the bookmark
    'objExcel.Visible = False
    'objWbk.Activate
    vNames = objWbk.Worksheets("Report").Range("Bookmarks").Value

    'loop through the bookmarks listed in the Excel range,
    'and if they exist in the current document, populate them
    For intCounter = LBound(vNames) To UBound(vNames)

        sBookmark = vNames(intCounter, 1)
        sSheet = vNames(intCounter, 2)
        sRange = vNames(intCounter, 3)
        sType = vNames(intCounter, 4)

        If objDoc.Bookmarks.Exists(sBookmark) = True Then
            On Error Resume Next
            If sType = "Table" Then
                'If section to be copied is a table
                objWbk.Worksheets(sSheet).Range(sRange).CopyPicture 1, -4147
                Call UpdateBookmarkField(objDoc, sBookmark, " ")
                Call UpdateBookmarkTableorChart(objDoc, sBookmark, sType)
            ElseIf sType = "Chart" Then
                'If section to be copied is a graph/chart
                objWbk.Worksheets(sSheet).ChartObjects(sRange).Copy
                Call UpdateBookmarkField(objDoc, sBookmark, " ")
                Call UpdateBookmarkTableorChart(objDoc, sBookmark, sType)
            Else
                'Do this routine if the section is a field
                Call UpdateBookmarkField(objDoc, sBookmark, objWbk.Worksheets(sSheet).Range(sRange))
            End If
            On Error GoTo 0
        End If

    Next intCounter

    If blnCloseWorkbook = True Then
        objWbk.Close True
    End If
    objDoc.Activate

Err_Exit:
    'clean up
    Set objWbk = Nothing
    objExcel.Visible = True
    Set objExcel = Nothing
    Set objDoc = Nothing

    Application.ScreenUpdating = True
    Application.ScreenRefresh
    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 = 9 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

Sub UpdateBookmarkField(docPopulate As Document, strBookmarkName As String, strBookmarkValue As String)

    Dim rngBookmarkRange As Range

    If docPopulate.Bookmarks.Exists(strBookmarkName) = False Then
        Exit Sub
    End If

    Set rngBookmarkRange = docPopulate.Bookmarks(strBookmarkName).Range
    rngBookmarkRange.Text = strBookmarkValue
    docPopulate.Bookmarks.Add Name:=strBookmarkName, Range:=rngBookmarkRange

    Set rngBookmarkRange = Nothing

End Sub

Sub UpdateBookmarkTableorChart(docPopulate As Document, strBookmarkName As String, strType As String)

    Dim rngBookmarkRange As Range
    Dim DefaultWrapType As WdWrapType
    Dim blnSmartPaste As Boolean

    If docPopulate.Bookmarks.Exists(strBookmarkName) = False Then
        Exit Sub
    End If

    DefaultWrapType = Options.PictureWrapType
    blnSmartPaste = Options.SmartCutPaste
    Set rngBookmarkRange = docPopulate.Bookmarks(strBookmarkName).Range

    rngBookmarkRange.Collapse direction:=wdCollapseStart

    Options.PictureWrapType = wdWrapMergeInline
    Options.SmartCutPaste = False

    If strType = "Chart" Then
        rngBookmarkRange.PasteAndFormat (wdChartPicture)
    Else
        rngBookmarkRange.PasteAndFormat (wdPasteDefault)
    End If

    docPopulate.Bookmarks(strBookmarkName).Range.Characters.Last.Delete

    Options.PictureWrapType = DefaultWrapType
    Options.SmartCutPaste = blnSmartPaste

    Set rngBookmarkRange = Nothing

End Sub

Leave a Reply

Your email address will not be published. Required fields are marked *