Word comment extraction: help getting numbered headings - excel

Question

I decided to learn VBA two weeks ago, and it's gone rather smooth. Now, however, I've encountered a problem I can't seem to solve on my own.
I've set up an excel document containing various modules. One of these modules extracts comments from a word document over to the excel sheet - which works as intended.
The problem is, I haven't been able to extract the first numbered header above each comment, which I'd very much like. Currently I have to do this manually after extracting the comments. As an example, I would like to also extract the first header and number above each comment, such as '2.1.1 Title'. If the comment is highlighting the header itself, it should be that header which is extracted as well.
I've tried a variety of things based on what I could find online, but every time I'm met with a variety of bugs I can't seem to fix. I've yet to find something that even sorta works. I did try one method which apparently should work in Word VBA, but I couldn't get it working within Excel.
Does anyone know how I would go about extracting the numbered headers? Any hints or tips will be greatly appreciated.
This is the code I have for the module:
Sub ImportCommentsDOCX()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim i As Integer
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
'1: if no comments'
With wdDoc
If wdDoc.Comments.Count = 0 Then
MsgBox ("No comments")
End If
'2; Set excel headers'
Range("B" & 1).Value = "Number"
Range("B" & 1).Font.Bold = True
Range("C" & 1).Value = "Comment"
Range("C" & 1).Font.Bold = True
Range("D" & 1).Value = "Highlighted text"
Range("D" & 1).Font.Bold = True
Range("E" & 1).Value = "Initials"
Range("B" & 1).Font.Bold = True
Range("F" & 1).Value = "Date (*Imprecise)"
Range("F" & 1).Font.Bold = True
'3: Extract comments and meta data'
For i = 1 To wdDoc.Comments.Count
Range("B" & 1 + i).Value = wdDoc.Comments(i).Index
Range("C" & 1 + i).Value = wdDoc.Comments(i).Range
Range("D" & 1 + i).Value = wdDoc.Comments(i).Scope.FormattedText
Range("E" & 1 + i).Value = wdDoc.Comments(i).Initial
Range("F" & 1 + i).Value = Format(wdDoc.Comments(i).Date, "dd/MM/yyyy") 'Unreliable: Sometimes gives wrong date'
'Range("G" & 3 + i).Value = wdDoc.Comments(i).Range.ListFormat.ListString 'Returns empty'
Next i
End With
Set wdDoc = Nothing
MsgBox ("Extraction has completed")
End Sub

Answer 1

Here is your code with some adjustments:
Sub ImportCommentsDOCX()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim i As Integer
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
'1: if no comments'
With wdDoc
wdDoc.Activate ' Added
If wdDoc.Comments.Count = 0 Then
MsgBox ("No comments")
End If
'2; Set excel headers'
Range("B" & 1).Value = "Number"
Range("B" & 1).Font.Bold = True
Range("C" & 1).Value = "Comment"
Range("C" & 1).Font.Bold = True
Range("D" & 1).Value = "Highlighted text"
Range("D" & 1).Font.Bold = True
Range("E" & 1).Value = "Initials"
Range("E" & 1).Font.Bold = True ' Modified
Range("F" & 1).Value = "Date (*Imprecise)"
Range("F" & 1).Font.Bold = True
'3: Extract comments and meta data'
For i = 1 To wdDoc.Comments.Count
Range("B" & 1 + i).Value = wdDoc.Comments(i).Index
Range("C" & 1 + i).Value = wdDoc.Comments(i).Range
Range("D" & 1 + i).Value = wdDoc.Comments(i).Scope.FormattedText
Range("E" & 1 + i).Value = wdDoc.Comments(i).Initial
Range("F" & 1 + i).Value = Format(wdDoc.Comments(i).Date, "dd/MM/yyyy") 'Unreliable: Sometimes gives wrong date'
'Range("G" & 1 + i).Value = wdDoc.Comments(i).Scope.ListFormat.ListString 'Returns empty' ' Modified ' Updated
Dim wp As Word.Paragraph: Set wp = wdDoc.Comments(i).Scope.Paragraphs(1) ' Updated
Do While wp.Range.ListFormat.ListString = "" ' Updated
Set wp = wp.Previous ' Updated
Loop ' Updated
Range("G" & 1 + i).Value = wp.Range.ListFormat.ListString ' Updated
Next i
End With
Set wdDoc = Nothing
MsgBox ("Extraction has completed")
End Sub
Please note my comments: Added and Modified
wdDoc.Activate was required at least on my computer, otherwise the
Range property is empty.
After initials a wrong column was bolded
The original text is referred to by the Range property, not the Scope (which is the content of the comment), so its ListFormat property should be used
The row index was not correct (3 instead of 1)

Answer 2

Looks working for me:
This requires Microsoft VBScript Regular Expression 5.5
Sub commentaires()
Dim regexOne As Object
Set regexOne = New RegExp
regexOne.Pattern = "^\d+\."
Dim s As String, s1 As String
Dim cmt As Word.Comment
Dim doc As Word.Document
For Each cmt In ActiveDocument.Comments
Dim wp As Word.Paragraph
Set wp = cmt.Scope.Paragraphs(1) ' Updated
Do While Not regexOne.Test(wp.Range.ListFormat.ListString)
Set wp = wp.Previous ' Updated
Loop ' Updated
s = s & _
wp.Range.ListFormat.ListString & ";" & _
cmt.Reference.Information(wdActiveEndAdjustedPageNumber) & ";""" & _
cmt.Scope & """;""" & _
cmt.Range.Text & """ " & vbCr
Next
Dim f As Integer
f = FreeFile
Open "c:\comments.csv" For Output As #f
Print #f, s
Close #f
End Sub