Word VBA Error: Object variable or With block variable not set (No debug option)

Hi all. I'm experiencing an error that I'm trying to get past with a Macro I wrote. The code is below. As an FYI, I'm using Word 2016 and Windows 10.

To explain the code you are looking at, the macro is intended to have a selected folder of Word documents containing track changes turned into tables and then combined into one spreadsheet with three columns of the text (one containing the track changes, one after accepting them and one after rejecting them). Also, the comments from the document are put into a column as well. Much of the code is preparing the documents so they look right when pasted into Excel.

The macro was working as intended but I put it down for a couple of weeks and went back to use it and am experiencing the following error:"Object variable or With block variable not set". No debug option is presented.

Before erroring out, it creates the Excel spreadsheet and opens the first Word document. I think it may have something to do with setting the track change settings.

At a loss at this point. Any help would be much appreciated.

Code:

---

Sub OnboardingWord()
'
' OnboardingData Macro
'
'


Dim sFolder As String
Dim sFile As String
Dim nFolder As String
Dim doc As Document
Dim tbl As Table
Dim arr() As Variant
Dim b As Byte
Dim pTable As Table
Dim xlapp As Object
Dim xlwb As Object
Dim xlws As Object
Dim oldColumn As Column
Dim newColumn1 As Column
Dim newColumn2 As Column
Dim newRow As Row
Dim nrRow As Long
Dim tRows As Long
Dim nFile As String
Dim temp1doc As Document
Dim temp2doc As Document
Dim tempColumn As Column
Dim temp1table As Table
Dim temp2table As Table
Dim commentText As String
Dim prevRng As Range
Dim prevRng2 As Range
Dim commentAuthor As String
Dim lastrow As Long
   
' Select Folder


    With Application.FileDialog(4)  ' msoFileDialogFolderPicker
        If .Show Then
            sFolder = .SelectedItems(1)
        Else
            MsgBox "No folder specified.", vbExclamation
            Exit Sub
        End If
    End With


Application.ScreenUpdating = False


    If Right(sFolder, 1) <> Application.PathSeparator Then
        sFolder = sFolder & Application.PathSeparator
    End If


' Create Folder Structure


    nFolder = sFolder & "Processed"
   
    FolderCreate (nFolder)
   
    nFolder = nFolder & Application.PathSeparator


Set xlapp = CreateObject("excel.application")
xlapp.Visible = True
Set xlwb = xlapp.workbooks.Add
xlwb.Activate
Set xlws = xlwb.ActiveSheet


xlwb.ActiveSheet.Cells(1, 1) = "Contract Name"
xlwb.ActiveSheet.Cells(1, 2) = "Row No."
xlwb.ActiveSheet.Cells(1, 3) = "Redline Text"
xlwb.ActiveSheet.Cells(1, 4) = "Original Text"
xlwb.ActiveSheet.Cells(1, 5) = "Modified Text"
xlwb.ActiveSheet.Cells(1, 6) = "Comments"




' Process Documents


       
        sFile = Dir(sFolder & "*.doc")
    Do Until sFile = ""
            Set doc = Documents.Open(sFolder & sFile)
            doc.Activate
        ' Disable Track Changes
       
            With doc
                .TrackRevisions = False
                .TrackMoves = False
                .TrackFormatting = False
            End With
           
        ' Configure Track Change Display Settings
           
            With ActiveWindow.View.RevisionsFilter
                .Markup = wdRevisionsMarkupAll
                .View = wdRevisionsViewFinal
            End With
            ActiveWindow.View.MarkupMode = wdMixedRevisions
            With Options
                .InsertedTextMark = wdInsertedTextMarkUnderline
                .InsertedTextColor = wdDarkBlue
                .DeletedTextMark = wdDeletedTextMarkStrikeThrough
                .DeletedTextColor = wdRed
                .RevisedPropertiesMark = wdRevisedPropertiesMarkNone
                .RevisedPropertiesColor = wdByAuthor
                .RevisedLinesMark = wdRevisedLinesMarkNone
                .CommentsColor = wdByAuthor
                .RevisionsBalloonPrintOrientation = wdBalloonPrintOrientationPreserve
            End With
            ActiveWindow.View.RevisionsMode = wdMixedRevisions
            With Options
                .MoveFromTextMark = wdMoveFromTextMarkDoubleStrikeThrough
                .MoveFromTextColor = wdGreen
                .MoveToTextMark = wdMoveToTextMarkDoubleUnderline
                .MoveToTextColor = wdGreen
                .InsertedCellColor = wdCellColorLightBlue
                .MergedCellColor = wdCellColorLightYellow
                .DeletedCellColor = wdCellColorPink
                .SplitCellColor = wdCellColorLightOrange
            End With
           
        ' Convert Tables to Text
       
            For Each tbl In doc.Tables
            tbl.ConvertToText Separator:=wdSeparateByParagraphs
            Next tbl
            Set tbl = Nothing
       
        ' Delete Shapes
       
            For i = doc.Shapes.Count To 1 Step -1
            doc.Shapes(i).Delete
            Next i
           
        ' Change to 1 Column
         
            Selection.WholeStory
            If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
                ActiveWindow.Panes(2).Close
            End If
            If ActiveWindow.ActivePane.View.Type <> wdPrintView Then
                ActiveWindow.ActivePane.View.Type = wdPrintView
            End If
            Selection.WholeStory
            Selection.PageSetup.TextColumns.SetCount NumColumns:=1
       
        ' Remove Numbering
       
            Selection.WholeStory
            Selection.Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
       
        ' Replace Section, Column and Page Breaks with Line Breaks
       
            Selection.WholeStory
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            arr = Array("^b", "^m", "^n")
                For b = LBound(arr) To UBound(arr)
                    With Selection.Find
                        .Text = arr(t)
                        .Replacement.Text = "^p"
                        .Wrap = wdFindContinue
                        .MatchWildcards = False
                    End With
                Selection.Find.Execute Replace:=wdReplaceAll
                Next
             
        ' Clear Formatting
       
            Selection.WholeStory
            Selection.ClearFormatting
           
        ' Convert Text to Table
       
            Selection.WholeStory
            Selection.ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, _
                AutoFitBehavior:=wdAutoFitFixed
            With Selection.Tables(1)
                .Style = "Table Grid"
                .ApplyStyleHeadingRows = False
                .ApplyStyleLastRow = False
                .ApplyStyleFirstColumn = False
                .ApplyStyleLastColumn = False
            End With
       
        ' Change Page Orientation
           
            If doc.PageSetup.Orientation = wdOrientPortrait Then
                doc.PageSetup.Orientation = wdOrientLandscape
            Else
                doc.PageSetup.Orientation = wdOrientPortrait
            End If
       
        ' Format Table
           
            If Right(sFile, 5) = ".docx" Then
                nFile = Left(sFile, Len(sFile) - 5)
            ElseIf Right(sFile, 5) = ".docm" Then
                nFile = Left(sFile, Len(sFile) - 5)
            ElseIf Right(sFile, 4) = ".doc" Then
                nFile = Left(sFile, Len(sFile) - 4)
            Else
                nFile = sFile
            End If
           
            Set pTable = ActiveDocument.Tables(1)
           
            Selection.WholeStory
            Selection.Font.Size = 8
            Selection.Font.Name = "Calibri Light"
            Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
           
           
            Set oldColumn = pTable.Columns(1)
                oldColumn.SetWidth ColumnWidth:=InchesToPoints(2), RulerStyle:=wdAdjustNone
           
               
            Set newColumn2 = pTable.Columns.Add(BeforeColumn:=pTable.Columns(1))
                newColumn2.SetWidth ColumnWidth:=InchesToPoints(0.5), RulerStyle:=wdAdjustNone
           
            Set newColumn1 = pTable.Columns.Add(BeforeColumn:=newColumn2)
                newColumn1.SetWidth ColumnWidth:=InchesToPoints(1), RulerStyle:=wdAdjustNone
           
            tRows = pTable.Rows.Count
           
            For nrRow = 1 To tRows
                pTable.Cell(nrRow, 1).Range.Text = nFile
            Next nrRow
           
            For nrRow = 1 To tRows
                pTable.Cell(nrRow, 2).Range.Text = nrRow
            Next nrRow
           
            Set newRow = pTable.Rows.Add(BeforeRow:=pTable.Rows(1))
                newRow.Height = InchesToPoints(0.5)
           
            pTable.Cell(1, 1).Range.Text = "Contract Name"
            pTable.Cell(1, 2).Range.Text = "Row No."
            pTable.Cell(1, 3).Range.Text = "Redline Text"


            pTable.Select
            Selection.Copy
            Set tempColumn = pTable.Columns.Add
                tempColumn.SetWidth ColumnWidth:=InchesToPoints(2), RulerStyle:=wdAdjustNone


            Set tempdoc1 = Documents.Add
            Set tempdoc2 = Documents.Add
           
            tempdoc2.Activate
            Selection.Paste
            tempdoc1.Activate
            Selection.Paste
           
            Set temptable1 = tempdoc1.Tables(1)
            tempdoc1.RejectAllRevisions
            If tempdoc1.Comments.Count > 0 Then tempdoc1.DeleteAllComments
            temptable1.Cell(1, 3).Range.Text = "Original Text"
            temptable1.Columns(3).Select
            Selection.Copy
            doc.Activate
            tempColumn.Select
            Selection.Paste
           
            tempdoc2.Activate
            Set temptable2 = tempdoc2.Tables(1)
            tempdoc2.AcceptAllRevisions
            If tempdoc2.Comments.Count > 0 Then tempdoc2.DeleteAllComments
            temptable2.Cell(1, 3).Range.Text = "Modified Text"
            temptable2.Columns(3).Select
            Selection.Copy
            doc.Activate
            tempColumn.Select
            Selection.Paste
           
            tempdoc1.Close SaveChanges:=False
            tempdoc2.Close SaveChanges:=False


            doc.Activate
           
            Selection.WholeStory
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = "^p"
                .Replacement.Text = "^l"
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchAllWordForms = False
                .MatchSoundsLike = False
                .MatchWildcards = False
            End With
            Selection.Find.Execute Replace:=wdReplaceAll
       
            Selection.WholeStory
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = "^l"
                .Replacement.Text = "^v"
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchAllWordForms = False
                .MatchSoundsLike = False
                .MatchWildcards = False
            End With
            Selection.Find.Execute Replace:=wdReplaceAll
           
            For Each cmt In doc.Comments
                Set rng = cmt.Scope
                rng.HighlightColorIndex = wdBrightGreen
                commentText = cmt.Range.Text
                commentAuthor = cmt.Contact
                rng.Select
                Selection.MoveRight Unit:=wdCell
                Selection.MoveRight Unit:=wdCell
                Selection.MoveRight Unit:=wdCell
                Set prevRng = Selection.Range
                Set prevRng2 = Selection.Range
                prevRng2.End = prevRng2.End - 1
                If Len(prevRng2.Text) = 0 Then
                    prevRng.InsertAfter Text:=commentAuthor & ": " & commentText
                Else
                    prevRng.InsertAfter Text:=Chr(182) & Chr(182) & commentAuthor & ": " & commentText
                End If
                rng.Select
            Next cmt


            pTable.Cell(1, 6).Range.Text = "Comments"
               
            If doc.Comments.Count > 0 Then doc.DeleteAllComments
           
            pTable.Rows(1).Delete
           
            pTable.Select
            Selection.Copy
           
            xlwb.Activate
            lastrow = xlws.Range("A1").CurrentRegion.Rows.Count
            lastrow = lastrow + 1
            xlapp.ActiveSheet.Cells(lastrow, 1).Activate
           
            xlwb.ActiveSheet.Paste
           
            doc.Activate
       
        ' Save Version Files
           
            doc.Close SaveChanges:=False
           
       
        sFile = Dir
    Loop
   
Application.ScreenUpdating = True
           
End Sub


Function FolderCreate(nFolder As String)


    On Error Resume Next
    ChDir nFolder
    If Err <> 0 Then
      MkDir (nFolder)
    Else
        Exit Function
    End If


End Function

---

You might try inserting a simple message box in your code (e.g. MsgBox "!") and progressively moving it down until the error occurs before the message box displays. You'll then know where to look in your code for the coding error.

Some code you may be interested in for exporting tracked changes & comments to Excel can be found in my posts of 3 November 2014 and 5 September 2015 at: https://answers.microsoft.com/en-us/...f-8dc609cc75af