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
