Copying bold words and corresponding page number

[Matthijs]

I know there are several posts about copying bold words but I'm not able to solve my problem with them. I was wondering if it is possible to write a VBA code in Word that puts all the bold words and their corresponding page number in a table at the end of the document. And if so, is there anyone who can help me in the right direction? Personally, I'm more familiar with VBA for Excel.

Thanks in advance!

[mana]

Option Explicit


Sub test()
Dim dic As Object
Dim r As Range, w, k
Dim tbl As Table, n As Long

Set dic = CreateObject("scripting.dictionary")

Set r = ActiveDocument.Content
With r.Find
.Font.Bold = True
Do While .Execute
For Each w In r.Words
If w.Text <> vbCr Then
dic(w.Text) = dic(w.Text) & "," & w.Information(wdActiveEndPageNumber)
End If
Next
Loop
End With


Set r = ActiveDocument.Bookmarks("\EndOfDoc").Range

Set tbl = ActiveDocument.Tables.Add(r, dic.Count, 2)

For Each k In dic
n = n + 1
tbl.Cell(n, 1).Range.Text = k
tbl.Cell(n, 2).Range.Text = Mid(dic(k), 2)
Next

End Sub

[Kilroy]

This code doesn't work with word 2016. "Set r" is used twice. Does this have something to do with it? Gets hung up on Set tbl = ActiveDocument.Tables.Add(r, dic.Count, 2)

[mana]

Would you post a sample data?


Option Explicit


Sub test2()
Dim dic As Object
Dim r As Range, w, k
Dim s As String, p As Long
Dim tbl As Table, n As Long

Set dic = CreateObject("scripting.dictionary")

Set r = ActiveDocument.Content
r.Collapse
With r.Find
.Font.Bold = True
Do While .Execute
For Each w In r.Words
s = Trim(w.Text)
If Len(s) > 1 Then
If Not dic.Exists(s) Then
Set dic(s) = CreateObject("scripting.dictionary")
End If
p = w.Information(wdActiveEndPageNumber)
dic(s)(p) = Empty
End If
Next
Loop
End With

If dic.Count = 0 Then Exit Sub

Set r = ActiveDocument.Bookmarks("\EndOfDoc").Range

Set tbl = ActiveDocument.Tables.Add(r, dic.Count, 2)

For Each k In dic
n = n + 1
tbl.Cell(n, 1).Range.Text = k
tbl.Cell(n, 2).Range.Text = Join(dic(k).keys, ",")
Next


End Sub

[Matthijs]

Would you post a sample data?


Option Explicit


Sub test2()
Dim dic As Object
Dim r As Range, w, k
Dim s As String, p As Long
Dim tbl As Table, n As Long

Set dic = CreateObject("scripting.dictionary")

Set r = ActiveDocument.Content
r.Collapse
With r.Find
.Font.Bold = True
Do While .Execute
For Each w In r.Words
s = Trim(w.Text)
If Len(s) > 1 Then
If Not dic.Exists(s) Then
Set dic(s) = CreateObject("scripting.dictionary")
End If
p = w.Information(wdActiveEndPageNumber)
dic(s)(p) = Empty
End If
Next
Loop
End With

If dic.Count = 0 Then Exit Sub

Set r = ActiveDocument.Bookmarks("\EndOfDoc").Range

Set tbl = ActiveDocument.Tables.Add(r, dic.Count, 2)

For Each k In dic
n = n + 1
tbl.Cell(n, 1).Range.Text = k
tbl.Cell(n, 2).Range.Text = Join(dic(k).keys, ",")
Next


End Sub


Thanks for the response, it works and is definitely helpful! However I was wondering if it is possible to keep word combinations together, for example new word as one string in the table instead of two different words.

[mana]

Option Explicit


Sub test3()
Dim dic As Object
Dim r As Range, k
Dim s As String, p As Long
Dim tbl As Table, n As Long

Set dic = CreateObject("scripting.dictionary")

Set r = ActiveDocument.Content
r.Collapse
With r.Find
.Font.Bold = True
Do While .Execute
s = Trim(r.Text)
If Len(s) > 1 Then
If Not dic.Exists(s) Then
Set dic(s) = CreateObject("scripting.dictionary")
End If
p = r.Information(wdActiveEndPageNumber)
dic(s)(p) = Empty
End If
Loop
End With

If dic.Count = 0 Then Exit Sub

Set r = ActiveDocument.Bookmarks("\EndOfDoc").Range

Set tbl = ActiveDocument.Tables.Add(r, dic.Count, 2)

For Each k In dic
n = n + 1
tbl.Cell(n, 1).Range.Text = k
tbl.Cell(n, 2).Range.Text = Join(dic(k).keys, ",")
Next

End Sub

[Matthijs]

Thank you so much! It works great!