Hi All,
I have been trying to modify a VBA script to count the comments in a word document and export them to an excel document.
The code works perfectly but I have been trying to add functionality. I would like to be able to count the number of paragraphs between the comment and numbered heading it sits under.
The original code uses a UDF called ParentLevel to grab the heading number for each comment. My theory was to copy this UDF and create another that returns the position of the heading, put this position into a range with the comment position, and then count the number of paragraphs in the range.
However, I keep getting an "invalid qualifier" for my new UDF.
The new code is between the "------------" and the new UDF is at the bottom, called "HeadStart"
Can anyone advise why my UDF is not working?
I have been trying to modify a VBA script to count the comments in a word document and export them to an excel document.
The code works perfectly but I have been trying to add functionality. I would like to be able to count the number of paragraphs between the comment and numbered heading it sits under.
The original code uses a UDF called ParentLevel to grab the heading number for each comment. My theory was to copy this UDF and create another that returns the position of the heading, put this position into a range with the comment position, and then count the number of paragraphs in the range.
However, I keep getting an "invalid qualifier" for my new UDF.
The new code is between the "------------" and the new UDF is at the bottom, called "HeadStart"
Can anyone advise why my UDF is not working?
Code:
Public myProgress As Long
Sub ExtractComments()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim xlWb As Workbook
Dim xlWbs As Workbook
Dim i As Integer, HeadingRow As Integer
Dim objPara As Word.Paragraph
Dim objComment As Word.Comment
Dim strSection As String
Dim docNumber As String
Dim strTemp
Dim myRange As Word.Range
strTemp = MsgBox("This takes about a minute", vbCritical)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set xlWb = Application.ThisWorkbook
' Open up right word document
Set wdApp = CreateObject("Word.Application")
wdApp.Options.DefaultFilePath(wdDocumentsPath) = xlWb.Path
With wdApp.FileDialog(msoFileDialogOpen)
.Show
.AllowMultiSelect = False
Set wdDoc = wdApp.Documents.Open(.SelectedItems(1))
End With
wdApp.Visible = True
With xlWb.Worksheets("INSERT FILE NAME")
HeadingRow = 24
' 4 = Author
' 5 = ID
' 6 = Section
' 7 = Para
' 8 = Page
' 9 = Comment
strSection = "preamble" 'all sections before "1." will be labeled as "preamble"
strTemp = "preamble"
If wdDoc.Comments.Count = 0 Then
MsgBox ("No comments")
Exit Sub
End If
'Add bits to extract documents details
For j = 1 To 27
If wdDoc.CustomDocumentProperties(j).Name = "Document Number" Then
.Cells(1 + HeadingRow, 1).Value = wdDoc.CustomDocumentProperties(j).Value
docNumber = wdDoc.CustomDocumentProperties(j).Value
ElseIf wdDoc.CustomDocumentProperties(j).Name = "Issue Number" Then
.Cells(1 + HeadingRow, 2).Value = wdDoc.CustomDocumentProperties(j).Value
ElseIf wdDoc.CustomDocumentProperties(j).Name = "Title" Then
.Cells(1 + HeadingRow, 3).Value = wdDoc.CustomDocumentProperties(j).Value
End If
Next j
'myProgress = 0
'UserForm1.Show vbModeless
'myProgressStep = 100 / wdDoc.Comments.Count
For i = 1 To wdDoc.Comments.Count
'myProgress = myProgress + myProgressStep
'UserForm1.Hide
'UserForm1.Show
Set myRange = wdDoc.Comments(i).Scope
'----------
CurPos = wdDoc.Comments(i).Range.End ' New Line - Get Current Position of Comment
HeadPos = HeadStart(myRange.Paragraphs(1)).End ' New Line - Get position of comment heading
Set rngPara = wdDoc.Range(Start:=HeadPos, End:=CurPos) ' New Line - Set range from heading to end of comment
GetParaNo = rngPara.Paragraphs.Count ' New Line - Count Paragraphs in range
'----------
strSection = ParentLevel(myRange.Paragraphs(1)) ' find the section heading for this comment
.Cells(i + HeadingRow, 4).Formula = wdDoc.Comments(i).Author
.Cells(i + HeadingRow, 5).Formula = wdDoc.Comments(i).Index
.Cells(i + HeadingRow, 6).Value = strSection
.Cells(i + HeadingRow, 7).Value = GetParaNo ' New Line
.Cells(i + HeadingRow, 8).Formula = wdDoc.Comments(i).Reference.Information(wdActiveEndAdjustedPageNumber)
.Cells(i + HeadingRow, 9).Formula = wdDoc.Comments(i).Range
Next i
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'Clean up and save
wdDoc.Close
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
savePath = xlWb.Path & "\Comments-" & docNumber & ".xlsx"
Set xlWbs = Workbooks.Add
xlWb.Sheets("SBU(D)-FM-098").Copy Before:=xlWbs.Sheets(1)
Application.DisplayAlerts = False
' xlWbs.Sheets("Sheet3").Delete
' xlWbs.Sheets("Sheet2").Delete
xlWbs.Sheets("Sheet1").Delete
Application.DisplayAlerts = True
xlWbs.SaveAs savePath
Application.ScreenUpdating = True
'xlWbs.Close savechanges:=False
'xlWb.Close savechanges:=False
End Sub
Function ParentLevel(Para As Word.Paragraph) As String
On Error GoTo Err:
Dim ParaAbove As Word.Paragraph
Set ParaAbove = Para
sStyle = Para.Range.ParagraphStyle
sStyle = Left(sStyle, 4)
If sStyle = "Head" Then
Else
Do While ParaAbove.OutlineLevel = Para.OutlineLevel
Set ParaAbove = ParaAbove.Previous
Loop
End If
strTitle = ParaAbove.Range.Text
strTitle = Left(strTitle, Len(strTitle) - 1)
ParentLevel = ParaAbove.Range.ListFormat.ListString ' & " " & strTitle
Exit Function
Err:
ParentLevel = "General"
End Function
Function HeadStart(Para As Word.Paragraph) As String
On Error GoTo Err:
Dim ParaAbove As Word.Paragraph
Set ParaAbove = Para
sStyle = Para.Range.ParagraphStyle
sStyle = Left(sStyle, 4)
If sStyle = "Head" Then
Else
Do While ParaAbove.OutlineLevel = Para.OutlineLevel
Set ParaAbove = ParaAbove.Previous
Loop
End If
HeadStart = ParaAbove.Range
Exit Function
Err:
HeadStart = "General"
End Function