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!