2
\$\begingroup\$

I previously asked this question but have since improved my code: Substituting bookmarks in a Word document with data combined from an Excel sheet

What happens in the code:

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. The bookmarks are filled with data from an Excel workbook (data in workbook is also manipulated significantly with this macro). One of the bookmarks gets substituted for a table that is created on a new worksheet, which compares different suppliers with one another.

With every iteration of the loop the macro slows down, making it incredibly slow toward the end. Pausing and resuming the code significantly speeds it up again. Any ideas what may be causing this and how to avoid it?

Private Sub SubBookmarks()

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

Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, ws5 As Worksheet

Dim table As Range, rngQ As Range, rngT1 As Range, rngT2 As Range, rngT3 As Range, rngC1 As Range, rngP1 As Range, rngP2 As Range, rngP3 As Range, ColRefT As Range, ColRefP As Range, ColQTY As Range
Dim rRng As Range, rng1 As Range, rng2 As Range, rng3 As Range, rCell As Range, ColNrTool As Range, delRange As Range, rngData As Range, Cell As Range
Dim rngTl1 As Range, rngTl2 As Range, rngTl3 As Range

Dim i As Long, n As Long, LastRow1 As Long, lastrow2 As Long, LastCol5 As Long
Dim ColNrQ As Long, RowNrT As Long, ColNrT1 As Long, ColNrT2 As Long, ColNrT3 As Long, RowNrP As Long, ColNrP1 As Long, ColNrP2 As Long, ColNrP3 As Long

Dim Rf1 As String, Rf2 As String, Rf3 As String, Descr As String, Form As String, Matr As String, Prin As String, Pack As String, SupName1 As String, SupName2 As String, SupName3 As String
Dim str As String, SupName As String, RefNr As String, openxml As String, Temp As String, Addr As String, SelectedSheets() As String, PickFolder As String, detail As String, tool As String

Dim bkm As Bookmark

Dim fdn As FileDialog

Dim wdApp As Object, wdDoc As Object

On Error GoTo ErrHandler

'Add Word 16.0 Reference Makro using GUID. Adding the macro and cross referencing public variables is not possible
    Dim strGUID As String, theRef As Variant
     'Update the GUID you need below.
    strGUID = "{00020905-0000-0000-C000-000000000046}"

     'Remove any missing references
    For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
        Set theRef = ThisWorkbook.VBProject.References.Item(i)
        If theRef.isbroken = True Then
            ThisWorkbook.VBProject.References.Remove theRef
        End If
        If ThisWorkbook.VBProject.References.Item(i).GUID = strGUID Then
        GoTo NoAdd
        End If
    Next i

     'Add the reference
    ThisWorkbook.VBProject.References.AddFromGuid _
    GUID:=strGUID, Major:=1, Minor:=0
    MsgBox "The 'Microsoft Word 16.0 Object Libraray' reference was added to the reference library. Please restart the macro"
    GoTo ExitSub

NoAdd:
'Define the three worksheets that were selected
        n = 0
    For Each ws In ActiveWorkbook.Windows(1).SelectedSheets
        ReDim Preserve SelectedSheets(n)
        SelectedSheets(n) = ws.Name
        n = n + 1
    Next

'Set active worksheet
    Set ws1 = ActiveWorkbook.ActiveSheet

'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

'Define worksheets 3 & 4, add ws5
    Set ws3 = ActiveWorkbook.Sheets("ANALYSIS - Lead Times")
    Set ws4 = ActiveWorkbook.Sheets("ANALYSIS - prices")
    With ThisWorkbook
    Set ws5 = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    ws5.Name = "Transposition"

'Define the names of the selected worksheets as supplier names
    End With
    SupName1 = SelectedSheets(0)
    SupName2 = SelectedSheets(1)
    SupName3 = SelectedSheets(2)

'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 and remove the empty Row 2
    ws1.Range("C3:C" & LastRow1).Copy ws2.Range("A:A")
    ws1.Range("I3:I" & LastRow1).Copy ws2.Range("B:B")
    ws1.Range("J3:N" & LastRow1).Copy ws2.Range("E:I")
    ws2.Rows(2).Delete

'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 on datasheet - makes makro slow, but is the fastest way I could find
    ws2.Activate
        With ws2
        For i = 1 To lastrow2
            If .Cells(i, 2).Font.Strikethrough = True Then
'This if statement adds all the identified rows to the range that will be deleted
                If delRange Is Nothing Then
                    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
    lastrow2 = ws2.Cells(Rows.Count, "B").End(xlUp).Row

'Set Ranges for ws2
    Set rng1 = ws2.Range("B2:B" & lastrow2)
    Set rng2 = ws2.Range("C2:C" & lastrow2)
    Set rng3 = ws2.Range("D2:D" & lastrow2)

'Copy parts of string in B to C & D in batch, rather than through a loop. If statement just makes sure that evaluate recognizes 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))")

'Find Columns which contain RefNr and Amounts
    ws3.Activate
    Set ColRefT = ws3.Range("1:1").Find("Ref.-No.", LookAt:=xlWhole).EntireColumn
    Set ColQTY = ws3.Range("1:1").Find("Amounts", LookAt:=xlWhole).EntireColumn
    ws4.Activate
    Set ColRefP = ws4.Range("1:1").Find("Ref.-No.", LookAt:=xlWhole).EntireColumn

'Select template
'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 ErrHandler
        End If
    End With

'open the word documents -  careful! Document can not be called "Template"!!! Leads to error
    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 file including bookmarks
        wdDoc.Application.Selection.Wholestory
        openxml = wdDoc.Application.Selection.WordOpenXML   'more stable than copy-paste
        wdDoc.Application.Selection.Delete

'This loop is what is taking so much time: Loop through each row in sheet, 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 into word document
        With wdDoc
            .Application.Selection.InsertXML XML:=openxml
            .Application.Selection.EndKey Unit:=wdStory
            .Application.Selection.InsertBreak Type:=wdPageBreak
        End With

'Set ReferenceNr. for every loop iteration
RefNr = ws2.Range("B" & i).Value

'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
        GoTo ErrHandler
    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 ErrHandler
    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 ErrHandler
    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 ErrHandler
    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 ErrHandler
    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 ErrHandler
    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 ErrHandler
    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 ErrHandler
    End If

'Find the ranges we want to copy on the time sheet
    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, ColQTY.Column), Cells(Cells(RowNrT + 3, ColNrT1).End(xlDown).Row, ColQTY.Column))
    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 the price sheet
    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
    rngC1.Copy
    ws5.Range("B1").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("B1").PasteSpecial xlPasteValues, Transpose:=True
    rngP1.Copy
    ws5.Range("B3").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("B3").PasteSpecial xlPasteValues, Transpose:=True
    rngT2.Copy
    ws5.Range("B4").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("B4").PasteSpecial xlPasteValues, Transpose:=True
    rngP2.Copy
    ws5.Range("B5").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("B5").PasteSpecial xlPasteValues, Transpose:=True
    rngT3.Copy
    ws5.Range("B6").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("B6").PasteSpecial xlPasteValues, Transpose:=True
    rngP3.Copy
    ws5.Range("B7").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("B7").PasteSpecial xlPasteValues, Transpose:=True

'Count all the non empty columns in ws5
LastCol5 = ws5.Cells(1, Columns.Count).End(xlToLeft).Column

'Add Titles for table
    With ws5
    .Activate
    .Range("A1") = "QTY"
    .Cells(1, LastCol5 + 1) = "Tool Cost"
    .Range("A2") = SupName1 & " LT"
    .Range("A3") = SupName1 & " Price (" & CurSign & ")"
    .Range("A4") = SupName2 & " LT"
    .Range("A5") = SupName2 & " Price (" & CurSign & ")"
    .Range("A6") = SupName3 & " LT"
    .Range("A7") = SupName3 & " Price (" & CurSign & ")"
    .Range("A1:A7").Font.Bold = True
    .Range("1:1").Font.Bold = True
    .Cells(3, LastCol5 + 1) = rngTl1.Value
    .Cells(5, LastCol5 + 1) = rngTl2.Value
    .Cells(7, LastCol5 + 1) = rngTl3.Value
    .Cells(3, LastCol5 + 1).NumberFormat = "0.00" & CurSign
    .Cells(5, LastCol5 + 1).NumberFormat = "0.00" & CurSign
    .Cells(7, LastCol5 + 1).NumberFormat = "0.00" & CurSign
    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
        Descr = ws2.Cells(i, 1).Value
        Form = ws2.Cells(i, 5).Value
        Matr = ws2.Cells(i, 6).Value
        Prin = ws2.Cells(i, 7).Value
        Pack = ws2.Cells(i, 8).Value
        detail = ws2.Cells(i, 9).Value
        tool = ""

'replace the bookmarks with the variables
        FillBookmark wdDoc, Rf1, "Rf1"
        FillBookmark wdDoc, Rf2, "Rf2"
        FillBookmark wdDoc, Rf3, "Rf3"
        FillBookmark wdDoc, Descr, "Descr"
        FillBookmark wdDoc, Form, "Form"
        FillBookmark wdDoc, Matr, "Matr"
        FillBookmark wdDoc, Prin, "Prin"
        FillBookmark wdDoc, Pack, "Pack"
        FillBookmark wdDoc, detail, "Detail"
        FillBookmark wdDoc, tool, "Tool"
        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
Dim msg As String

ErrHandler:
If Err.Number <> 0 Then
     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"
     Else: msg = "Error # " & Err.Number & " was generated by " & Err.Source & Chr(13) & Chr(13) & Err.Description
     MsgBox msg, , "Error", Err.HelpFile, Err.HelpContext
     End If
End If

'Reset Workbook settings
    Application.DisplayAlerts = False
    ws2.Delete
    ws5.Delete
    Application.DisplayAlerts = True
    ws1.Activate
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
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
\$\endgroup\$
2
\$\begingroup\$

Naming variables

Give your variables meaningful names. Characters are free and when you know what something is by looking at its name, it's so much easier to follow the code! A few examples:

  1. rngP1 might be better off as something like firstParagraph
  2. You'll notice I said "to hell!" with that hungarian notation - it's unneeded!
  3. Here:

LastRow1 As Long, lastrow2

You should never need numbers in variable names; that suggests you need more descriptive names. Also you've been inconsistent with your capitalization Standard VBA naming conventions have camelCase for local variables and PascalCase for other variables and names.

  1. Here:

Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, ws5 As Worksheet

Worksheets have a CodeName property - View Properties window (F4) and the (Name) field (the one at the top) can be used as the worksheet name. This way you can avoid Sheets("mySheet") and instead just use mySheet. And just avoid those variables altogether

  1. This
Dim strGUID As String, theRef As Variant
'Update the GUID you need below.
strGUID = "{00020905-0000-0000-C000-000000000046}"

Would be better as something like

Const WORD_GUID as String = "{00020905-0000-0000-C000-000000000046}"

Since it never changes. You can also apply this logic to places like this -

Set ws3 = ActiveWorkbook.Sheets("ANALYSIS - Lead Times")
Set ws4 = ActiveWorkbook.Sheets("ANALYSIS - prices")

With

Const LEAD_SHEET_NAME As String = "ANALYSIS - Lead Times"
Const PRICES_SHEET_NAME As String = "ANALYSIS - prices"

Set ws3 = ActiveWorkbook.Sheets(LEAD_SHEET_NAME)
Set ws4 = ActiveWorkbook.Sheets(PRICES_SHEET_NAME)

The reason to do this is so that you can keep track of things that don't change often more easily and be able to change them without searching everywhere for them.


Also, take a look at this

If theRef.isbroken = True Then
ThisWorkbook.VBProject.References.Remove theRef
End If

You're using an If Then with a Boolean, so it can be simplified because theRef.isbroken will only return TRUE or FALSE

If theRef.isbroken then ThisWorkbook.VBProject.References.Remove theRef

I also made it single line, but that's my preference - I don't see the need for the if block if it's a single action.

As for an example as to why you beef up your naming -

SupName1 = SelectedSheets(0)
SupName2 = SelectedSheets(1)
SupName3 = SelectedSheets(2)

I'm not sure what's going on here at all. I take it we're getting names of something from the SelectedSheets property, but I don't know why, how or what the input should look like.


Like watching glue dry..

copy and paste the appropriate ranges
    rngC1.Copy
    ws5.Range("B1").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("B1").PasteSpecial xlPasteValues, Transpose:=True
    rngP1.Copy
    ws5.Range("B3").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("B3").PasteSpecial xlPasteValues, Transpose:=True
    rngT2.Copy
    ws5.Range("B4").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("B4").PasteSpecial xlPasteValues, Transpose:=True
    rngP2.Copy
    ws5.Range("B5").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("B5").PasteSpecial xlPasteValues, Transpose:=True
    rngT3.Copy
    ws5.Range("B6").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("B6").PasteSpecial xlPasteValues, Transpose:=True
    rngP3.Copy
    ws5.Range("B7").PasteSpecial xlPasteFormats, Transpose:=True
    ws5.Range("B7").PasteSpecial xlPasteValues, Transpose:=True

According to Durgess you can just get both values and formats with a single argument and avoid clipboard by not copy and paste-ing. Trust me, that's slow!


Also, it seems like you're doing a lot of things one at a time when you may be able to do many things at the same time with arrays, but I'll have to spend some more time looking at the code.


Notes

You have GoTo ExitSub but I don't see that label anywhere.

Your spacing for your With block got messed up

    With ThisWorkbook
    Set ws5 = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    ws5.Name = "Transposition"

'Define the names of the selected worksheets as supplier names
    End With
\$\endgroup\$
  • \$\begingroup\$ Just to clear some things up: SupName is the name of the worksheet, which is named after a supplier. I later look for that supplier name in a different worksheet, where all of the supplier data is combined. So it serves as an identifier for which column I need to look at. The GoTo ExitSub is something I must have missed from an earlier version of the code and which I'll remove. I will implement your suggested changes and let you know how they turned out. Thanks for that extensive code review! \$\endgroup\$ – Da Spotz Oct 25 '16 at 8:24
  • \$\begingroup\$ It was the copy and pasting (like watching glue dry) which was slowing everything down. When I realised that I didn't actually need to maintain the format it was an easy fix. I will post the solution as another answer. Thanks again for the great review, it's some very useful advice for how to approach my programming in the future \$\endgroup\$ – Da Spotz Oct 25 '16 at 13:52

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.