VBA Macro - Speed decreasing with every loop iteration - substituting Word bookmarks from Excel

Question

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

Answer 1

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.

4. 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

5. 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

• Da Spotz: 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!
• Da Spotz: 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