I previously asked this question but have since improved my code: Substituting bookmarks in a Word document with data combined from an Excel sheetWhat 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 = FalseDim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, ws5 As WorksheetDim 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 RangeDim 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 RangeDim rngTl1 As Range, rngTl2 As Range, rngTl3 As RangeDim i As Long, n As Long, LastRow1 As Long, lastrow2 As Long, LastCol5 As LongDim 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 LongDim 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 StringDim 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 StringDim bkm As BookmarkDim fdn As FileDialogDim wdApp As Object, wdDoc As ObjectOn 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 ExitSubNoAdd:'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 iterationRefNr = 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 ws5LastCol5 = 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 WithDim msg As StringErrHandler: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 IfEnd 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 = TrueEnd SubSub 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 wasnt 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, wdRngEnd Sub
VBA Macro - Speed decreasing with every loop iteration - substituting Word bookmarks from Excel
vba;excel;ms word
Naming variablesGive 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:rngP1 might be better off as something like firstParagraphYou'll notice I said to hell! with that hungarian notation - it's unneeded!Here:LastRow1 As Long, lastrow2You 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.Here:Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet, ws3 As  Worksheet, ws4 As Worksheet, ws5 As WorksheetWorksheets 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 altogetherThisDim strGUID As String, theRef As Variant'Update the GUID you need below.strGUID = {00020905-0000-0000-C000-000000000046}Would be better as something likeConst 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)WithConst LEAD_SHEET_NAME As String = ANALYSIS - Lead TimesConst PRICES_SHEET_NAME As String = ANALYSIS - pricesSet 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 thisIf theRef.isbroken = True ThenThisWorkbook.VBProject.References.Remove theRefEnd IfYou're using an If Then with a Boolean, so it can be simplified because theRef.isbroken will only return TRUE or FALSEIf theRef.isbroken then ThisWorkbook.VBProject.References.Remove theRefI 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:=TrueAccording 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.NotesYou 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