mross
01-17-2019, 09:01 AM
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
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