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.
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
Reply With Quote
