Substituting bookmarks in a Word document with data combined from an Excel sheet

Question

I have managed to write code that does something fairly complex. It's working as I need it to, but it is so slow.

Information about a list of suppliers needs to be consolidated into a word document that maintains the same layout on all pages. To do this, a document in the required layout has been created with bookmarks, which get substituted and re-added to the end of the word document with every iteration of the loop.

One of the bookmarks gets substituted for a table that is created on a new worksheet, which compares different suppliers with one another.

I have tried my best to make it faster, but I was wondering if any of you have any input on what else I could do to speed up what I've got. I couldn't figure out a better way to accomplish what I needed to do, so any input on better approaches would be more than welcome (the loop at the end is what's taking the most time).

Right now the code takes somewhere between 5-10 minutes to complete all calculations and so I figured that there must be a better way.

Sub MarketingPrep()

'Increase speed of makro
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False

'PART 1: Copying Data from a sheet and splitting up that information into parts, as well as deleting anything that isstruck through

Dim ws1, ws2 As Worksheet
Dim delRange As Range       'delrange must be set seperately here, why I don't know.
Dim rRng, rng1, rng2, rng3, rCell As Range
Dim a, i, n, LastRow1, lastrow2 As Integer
Dim fdn As FileDialog
Dim wdApp, wdDoc As Object
Dim Addr, Temp, openxml As String
Dim Rf1, Rf2, Rf3, Descr, Form, Matr, Prin, Pack, SelectedSheets() As String
Dim ws3, ws4, ws5 As Worksheet
Dim str, SupName, RefNr As String
Dim ColNrQ, RowNrT, ColNrT, RowNrP, ColNrP As Integer
Dim table, rngQ, rngT, rngC, rngP, ColRefT, ColRefP As Range

'Define active worksheet as ws1
    Set ws1 = ActiveWorkbook.ActiveSheet

'Define the three selected sheets as selectedsheets(n)
        n = 0
    For Each ws In ActiveWorkbook.Windows(1).SelectedSheets
        ReDim Preserve SelectedSheets(n)
        SelectedSheets(n) = ws.Name
        n = n + 1
    Next

'Add a new Worksheet at the end of all sheets to store the data from the file
    With ThisWorkbook
        Set ws2 = .Sheets.Add(After:=.Sheets(.Sheets.Count))
        ws2.Name = "Datasheet"
    End With
'Find Lastrow in ws1
    LastRow1 = ws1.Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row

'Paste relevant data into the new sheet
    ws1.Range("C1:C" & LastRow1).Copy ws2.Range("A:A")

'Find Lastrow in ws2
    lastrow2 = ws2.Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row

'Delete all cells that are in the format strikethrough - makes makro slow, but is the fastest I could find
    With ws2
        For i = 1 To lastrow2
            If .Cells(i, 2).Font.Strikethrough = True Then
                If delRange Is Nothing Then 'This if statement adds all the identified rows to the range that will be deleted
                    Set delRange = .Rows(i)
                Else
                    Set delRange = Union(delRange, .Rows(i))
                End If
            End If
        Next i
       If Not delRange Is Nothing Then delRange.Delete
    End With

'Count the remaining entries on ws2
    lastrow2 = ws2.Cells(Rows.Count, "B").End(xlUp).Row

'Set Ranges for ws2
    Set rng1 = ws2.Range("A1:A" & lastrow2)
    Set rng2 = ws2.Range("B1:B" & lastrow2)
    Set rng3 = ws2.Range("C1:C" & lastrow2)

'Copy parts of string in A to B & C in batch, rather than through a loop. If statement just makes sure that evaluate recognises the result is an array
    rng2.Value = Evaluate("if(row(" & rng1.Address & ")+column(" & rng1.Address & "),left(" & rng1.Address & ",2))")
    rng3.Value = Evaluate("if(row(" & rng1.Address & ")+column(" & rng1.Address & "),mid(" & rng1.Address & ",3,3))")

'Select a file with bookmarks that serves as a template for the word document I want to create
'Set Folder in which the template is located
    PickFolder = "C:\Users\atq01174\Desktop\Contract Preperation"

    Set fdn = Application.FileDialog(msoFileDialogFilePicker)

    With fdn
        .AllowMultiSelect = False
        .Title = "Please select the template file"
        .Filters.Clear
        .InitialFileName = PickFolder
        If .Show = True Then
        Temp = fdn.SelectedItems(1)
        Else: GoTo ErrorHandler
        End If
    End With

'PART2: Open the selected word document in order to paste data from the worksheet

'open the word documents -  careful! Document can not be called "Template"!!!
    Set wdApp = CreateObject("Word.Application")
    Set wdDoc = wdApp.Documents.Open(Temp)
'show the word document - put outside of loop for speed later
    wdApp.Visible = True

'Copy the content of the word document via wordopenxml, because it is more stable than copy paste
    wdDoc.Application.Selection.Wholestory
    openxml = wdDoc.Application.Selection.WordOpenXML
    wdDoc.Application.Selection.Delete

'Define more sheets in th eworkbook
    Set ws3 = ActiveWorkbook.Sheets("Sheet3")
    Set ws4 = ActiveWorkbook.Sheets("Sheet4")
    With ThisWorkbook
        Set ws5 = .Sheets.Add(After:=.Sheets(.Sheets.Count))
        ws5.Name = "Transposition"

    End With

'Get the sheet names from the selected sheets because they contain the supplier names
    SupName1 = SelectedSheets(0)
    SupName2 = SelectedSheets(1)
    SupName3 = SelectedSheets(2)

'Part 3: Loop through each row of data in the created sheet "datasheet" and add the values to the bookmarks

    For i = 2 To lastrow2

'Delete any existing bookmarks. Duplicate bookmarks are a no-no!
        For Each bkm In wdDoc.Bookmarks
            bkm.Delete
        Next bkm
'Insert copied text
        With wdDoc
            .Application.Selection.InsertXML XML:=openxml
            .Application.Selection.EndKey Unit:=wdStory
            .Application.Selection.InsertBreak Type:=wdPageBreak
        End With

'get the identifier for each row (RefNr) from the datasheet
RefNr = ws2.Range("B" & i).Value

'Find Column in which the Reference Nr. is
    ws3.Activate
    Set ColRefT = ws3.Range("1:1").Find("Ref.-No.", LookAt:=xlWhole).EntireColumn
    ws4.Activate
    Set ColRefP = ws4.Range("1:1").Find("Ref.-No.", LookAt:=xlWhole).EntireColumn

'Find the position of where Suppliername and Ref.No intersect on time and price sheet while making sure both exist on the sheet
    If Not VBA.IsError(Application.Match(SupName1, ws3.Range("1:1"), 0)) Then
        ColNrT1 = WorksheetFunction.Match(SupName1, ws3.Range("1:1"), 0)
        Else: MsgBox "The supplier name '" & SupName1 & "' could not be found on the sheet" & ws3.Name

    End If

    If Not VBA.IsError(Application.Match(SupName2, ws3.Range("1:1"), 0)) Then
        ColNrT2 = WorksheetFunction.Match(SupName2, ws3.Range("1:1"), 0)
        Else: MsgBox "The supplier name '" & SupName2 & "' could not be found on the sheet" & ws3.Name
        GoTo ErrorHandler
    End If

    If Not VBA.IsError(Application.Match(SupName3, ws3.Range("1:1"), 0)) Then
        ColNrT3 = WorksheetFunction.Match(SupName3, ws3.Range("1:1"), 0)
        Else: MsgBox "The supplier name '" & SupName3 & "' could not be found on the sheet" & ws3.Name
        GoTo ErrorHandler
    End If

    If Not VBA.IsError(Application.Match(RefNr, ColRefT, 0)) Then
        RowNrT = WorksheetFunction.Match(RefNr, ColRefT, 0)
        Else: MsgBox "The Reference Nr. '" & RefNr & "' could not be found on the sheet" & ws3.Name
        GoTo ErrorHandler
    End If

    If Not VBA.IsError(Application.Match(SupName1, ws4.Range("1:1"), 0)) Then
        ColNrP1 = WorksheetFunction.Match(SupName1, ws4.Range("1:1"), 0)
        Else: MsgBox "The supplier name '" & SupName1 & "' could not be found on the sheet" & ws4.Name
        GoTo ErrorHandler
    End If

    If Not VBA.IsError(Application.Match(SupName2, ws4.Range("1:1"), 0)) Then
        ColNrP2 = WorksheetFunction.Match(SupName2, ws4.Range("1:1"), 0)
        Else: MsgBox "The supplier name '" & SupName2 & "' could not be found on the sheet" & ws4.Name
        GoTo ErrorHandler
    End If

    If Not VBA.IsError(Application.Match(SupName3, ws4.Range("1:1"), 0)) Then
        ColNrP3 = WorksheetFunction.Match(SupName3, ws4.Range("1:1"), 0)
        Else: MsgBox "The supplier name '" & SupName3 & "' could not be found on the sheet" & ws4.Name
        GoTo ErrorHandler
    End If

    If Not VBA.IsError(Application.Match(RefNr, ColRefP, 0)) Then
        RowNrP = WorksheetFunction.Match(RefNr, ColRefP, 0)
        Else: MsgBox "The Reference Nr. '" & RefNr & "' could not be found on the sheet" & ws4.Name
        GoTo ErrorHandler
    End If



'Find the ranges we want to copy on sheet3
    ws3.Activate
    Set rngT1 = ws3.Range(Cells(RowNrT + 3, ColNrT1), Cells(Cells(RowNrT + 3, ColNrT1).End(xlDown).Row, ColNrT1))
    Set rngQ = ws3.Range(Cells(RowNrT + 3, 5), Cells(Cells(RowNrT + 3, ColNrT1).End(xlDown).Row, 5))
    Set rngC1 = Union(rngQ, rngT1)
    Set rngT2 = ws3.Range(Cells(RowNrT + 3, ColNrT2), Cells(Cells(RowNrT + 3, ColNrT2).End(xlDown).Row, ColNrT2))
    Set rngT3 = ws3.Range(Cells(RowNrT + 3, ColNrT3), Cells(Cells(RowNrT + 3, ColNrT3).End(xlDown).Row, ColNrT3))

'Find the ranges we want to copy on sheet4
    ws4.Activate
    Set rngP1 = ws4.Range(Cells(RowNrP + 3, ColNrP1), Cells(Cells(RowNrP + 3, ColNrP1).End(xlDown).Row - 4, ColNrP1))
    Set rngP2 = ws4.Range(Cells(RowNrP + 3, ColNrP2), Cells(Cells(RowNrP + 3, ColNrP2).End(xlDown).Row - 4, ColNrP2))
    Set rngP3 = ws4.Range(Cells(RowNrP + 3, ColNrP3), Cells(Cells(RowNrP + 3, ColNrP3).End(xlDown).Row - 4, ColNrP3))
    Set rngTl1 = Cells(Cells(RowNrP + 3, ColNrP1).End(xlDown).Row, ColNrP1)
    Set rngTl2 = Cells(Cells(RowNrP + 3, ColNrP2).End(xlDown).Row, ColNrP2)
    Set rngTl3 = Cells(Cells(RowNrP + 3, ColNrP3).End(xlDown).Row, ColNrP3)

'Format prices in table
    rngP1.NumberFormat = "0.000"
    rngP2.NumberFormat = "0.000"
    rngP3.NumberFormat = "0.000"

'copy and paste the appropriate ranges to create a table
    rngC1.Copy
    ws5.Range("C1").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("C1").PasteSpecial xlPasteValues, Transpose:=True
    rngP1.Copy
    ws5.Range("C3").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("C3").PasteSpecial xlPasteValues, Transpose:=True
    rngT2.Copy
    ws5.Range("C4").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("C4").PasteSpecial xlPasteValues, Transpose:=True
    rngP2.Copy
    ws5.Range("C5").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("C5").PasteSpecial xlPasteValues, Transpose:=True
    rngT3.Copy
    ws5.Range("C6").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("C6").PasteSpecial xlPasteValues, Transpose:=True
    rngP3.Copy
    ws5.Range("C7").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("C7").PasteSpecial xlPasteValues, Transpose:=True

'Add Titles for table
    With ws5
    .Activate
    .Range("A1") = "QTY"
    .Range("B1") = "Tool Cost"
    .Range("A2") = SupName1 & " LT"
    .Range("A3") = SupName1 & " Price"
    .Range("A4") = SupName2 & " LT"
    .Range("A5") = SupName2 & " Price"
    .Range("A6") = SupName3 & " LT"
    .Range("A7") = SupName3 & " Price"
        With .Range("A1:A7")
            .Font.Bold = True
            .Borders.LineStyle = xlContinuous
        End With
    .Range("1:1").Font.Bold = True
    .Range("B3") = rngTl1.Value
    .Range("B5") = rngTl2.Value
    .Range("B7") = rngTl3.Value
    End With

 'Get values from excel sheet
        Rf1 = ws2.Cells(i, 4).Value
        Rf2 = ws2.Cells(i, 2).Value
        Rf3 = ws2.Cells(i, 3).Value
        Tool = ""

'replace the bookmarks with the variables and the table created on ws5
        FillBookmark wdDoc, Rf1, "Rf1"
        FillBookmark wdDoc, Rf2, "Rf2"
        FillBookmark wdDoc, Rf3, "Rf3"
        FillBookmark wdDoc, Tool, "Tool"
        table = ws5.UsedRange.Copy
        wdDoc.Bookmarks("Table").Range.PasteExcelTable LinkedToExcel:=False, _
        WordFormatting:=True, RTF:=False
        ws5.UsedRange.Delete
        wdDoc.Tables(i - 1).Range.Font.Size = 9
        wdDoc.Tables(i - 1).AutoFitBehavior (wdAutoFitWindow)
    Next i

'Remove last Page Break in word document
    With wdDoc.Application
        .Selection.TypeBackspace
        .Selection.TypeBackspace
    End With

'selete the newly created worksheet for storing the table data
    ws5.Delete

ErrorHandler:
    If Err.Number = 9 Then
        MsgBox "A runtime Error 9 occured. This probably means that less than 3 worksheets were selected. Please select 3 different sheets (holding the Ctrl key) and restart the makro. Should this not fix the problem, please step through the VBA code and search for the error"
    End If
'Delete worksheet in which data was stored
    Application.DisplayAlerts = False
    ws2.Delete
    Application.DisplayAlerts = True
'Reactivate everything that was deactivated before
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
Exit Sub
End Sub

Sub FillBookmark(ByRef wdDoc As Object, _
    ByVal vValue As Variant, _
    ByVal sBmName As String, _
    Optional sFormat As String)

    Dim wdRng As Object

'store the bookmarks range
    Set wdRng = wdDoc.Bookmarks(sBmName).Range
'if the optional format wasn’t supplied
    If Len(sFormat) = 0 Then
'replace the bookmark text
       wdRng = vValue
    Else
'replace the bookmark text with formatted text
       wdRng.Text = Format(vValue, sFormat)
    End If
're-add the bookmark because the above destroyed it
'    wdRng.Bookmarks.Add sBmName, wdRng
End Sub

Answer 1

One quick note in terms of performance. When you do this

Dim ws1, ws2 As Worksheet
Dim rRng, rng1, rng2, rng3, rCell As Range

You are only giving ws1 and rCell a type. To give everything a type you need to do it like this -

Dim ws1 as Worksheet, ws2 as Worksheet

Or, since there's no real reason to combine them onto a single line -

Dim ws1 as Worksheet
Dim ws2 as Worksheet

I bring it up because when you don't define your variable, VBA will declare it as a Variant, which are objects:

Performance. A variable you declare with the Object type is flexible enough to contain a reference to any object. However, when you invoke a method or property on such a variable, you always incur late binding (at run time). To force early binding (at compile time) and better performance, declare the variable with a specific class name, or cast it to the specific data type.

By not declaring variables, you could possibly be paying a penalty.