I have a workbook that has a ton of data on it, and I need to copy it to an existing word document. The code I have seems to randomly error out at different places during the copy process.

I can't find any reason to it, but here are the bits of code I have noticed cause errors the most often:
.Selection.PasteExcelTable False, False, False
aTable.ConvertToText (wdSeparateByTabs)
ThisPar.TabStops.Add Position:=InchesToPoints(2), Leader:=wdTabLeaderDots
It is not always the same error, and it is not every time. Sometimes it will run all the way through with no problem. Other times it will error out. I will click end, close the word document, run the code again and it will find a different error, or run fine.

Here is my whole code:
Sub Macro1()

Dim lastrow As Long
Dim DataArea As String
Dim mergerow As Long
Dim i, x

lastrow = Sheet1.Range("L1").Value
DataArea = "Query!A1:J" & lastrow

Sheet3.Activate
Range("A1").Select
    ActiveSheet.PivotTables("PricingPivot").ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=DataArea, Version:=xlPivotTableVersion14)
    ActiveSheet.PivotTables("PricingPivot").PivotCache.Refresh

lastrow = Sheet3.Range("D1").Value

Sheet4.Cells.Delete
Sheet4.Cells.Clear
Sheet4.Cells.Font.Size = 12

Range("A2:B" & lastrow).Copy
Sheet4.Range("A1").PasteSpecial xlPasteFormulasAndNumberFormats

Sheet4.Activate

i = 1
lastrow = Sheet3.Range("F1").Value
    For i = 1 To lastrow
        If Range("A" & i).Value = "" And Not Range("B" & i).Value = "" Then Range("A" & i).EntireRow.Delete
    Next

i = 1
lastrow = Sheet3.Range("F1").Value
    For i = 1 To 108
            Range("A" & i & ":B" & i).Select
            With Selection
                .MergeCells = True
                .HorizontalAlignment = xlCenter
                .Font.Bold = True
                .Font.Size = 16
            End With

        i = i + 1
            Range("A" & i & ":B" & i).Select
            With Selection
                .MergeCells = True
                .HorizontalAlignment = xlCenter
                .Font.Bold = True
                .Font.Size = 14
            End With
        i = Selection.End(xlDown).Row + 1
    Next



i = 1
lastrow = Sheet3.Range("F1").Value
    For i = 1 To 108
        If Range("A" & i).Value = "" And Range("B" & i).Value = "" Then
            Rows(i & ":" & i).Select
                Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Range("A" & i & ":B" & i).Select
                Selection.MergeCells = True
                Selection.Value = "Patterns not listed are no longer available."
                Selection.Font.Size = 13
                Selection.Font.Bold = True
            i = i + 2
        End If
    Next

Sheet4.Columns("A:B").AutoFit

    Set WordApp = CreateObject("word.Application")
    WordApp.documents.Open "C:\Users\Chad\Desktop\Sample Book Pricing Kit - Template.docx"
    WordApp.Visible = True

Range("A1:B1").Select

For i = 1 To 108
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    
    Dim ThisPar As Paragraph
    WordApp.Activate
        With WordApp
            .ActiveDocument.Characters.Last.Select
            .Selection.PasteExcelTable False, False, False
    
            For Each aTable In WordApp.ActiveDocument.Tables
                aTable.ConvertToText (wdSeparateByTabs)
            Next
            
            .ActiveDocument.Characters.Last.Select
            .Selection.InsertBreak (wdColumnBreak)

        End With
    
    ThisWorkbook.Activate
        Selection.End(xlDown).Select
            i = Selection.Row
        Selection.End(xlDown).Select
        Range(Selection, Selection.End(xlDown)).Select
Next

WordApp.Activate
    With WordApp
            For Each ThisPar In WordApp.ActiveDocument.Paragraphs
                ThisPar.TabStops(1).Clear
                ThisPar.TabStops.Add Position:=InchesToPoints(2), Leader:=wdTabLeaderDots
                ThisPar.Alignment = wdAlignParagraphCenter
            Next ThisPar
           
    End With

End Sub