Microsoft Office Forums - View Single Post - [Solved] Auto generation of a Glossary of terms

Sc0tt1e · 03-29-2018, 01:52 AM

Hi all,

I am attempting to put together some code that will review a project document that will be manually created (where the code will be based) and the code will check a list of terms held in another document (terms doc) against the content of the project doc and if the words in the terms doc are present in the main doc I need a table to be inserted in the end of the document containing the word and the description.

I found the below code which is similar but only list the word and the page it was found on and I was wondering if anyone could help me with what would need adjusting to make this work for my required purposes (or if they have something that would work) I would be grateful for the assistance/support?

Code:

Sub TabulateKeyTerms()
Application.ScreenUpdating = False
Dim Doc As Document, RefDoc As Document, Rng As Range
Dim StrTerms As String, strFnd As String, StrPages As String
Dim i As Long, j As Long, StrOut As String, StrBreak As String
 
StrOut = "Term" & vbTab & "Pages" & vbTab & "Term" & vbTab & "Pages" & vbCr
Set Doc = ActiveDocument
Set RefDoc = Documents.Open("Drive:\FilePath\KeyTerms.doc", AddtorecentFiles:=False)
StrTerms = RefDoc.Range.Text
RefDoc.Close False
Set RefDoc = Nothing
 
' I think this searches the content of the document against the terms of ref doc. strFind loops each term one at a time
For i = 0 To UBound(Split(StrTerms, vbCr))
  strFnd = Trim(Split(StrTerms, vbCr)(i))
  If strFnd = "" Then GoTo NullString
  StrPages = ""
  With Doc.Content
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = False
      .Text = strFnd
      .Wrap = wdFindStop
      .MatchWholeWord = True
      .MatchWildcards = False
      .MatchCase = True
      .Execute
    End With
 
' I think this counts the page numbers if there is more than 1 reference to the term?
    j = 0
    Do While .Find.Found
      If j <> .Duplicate.Information(wdActiveEndPageNumber) Then
        j = .Duplicate.Information(wdActiveEndPageNumber)
        StrPages = StrPages & j & " "
      End If
      .Find.Execute
    Loop
 
'I think this splits out the page numbers after the term with a space then a comma and space between each page number?
    StrPages = Replace(Trim(StrPages), " ", ",")
    If StrPages <> "" Then
      If i Mod 2 = 0 Then StrBreak = vbTab Else StrBreak = vbCr
      StrOut = StrOut & strFnd & vbTab & ParsePageRefs(StrPages) & StrBreak
    End If
  End With
 
NullString:
Next I
 
' I think this creates the table ? (Will I need 4 columns)
Set Rng = Doc.Range.Characters.Last
With Rng
  .InsertAfter vbCr & Chr(12) & StrOut
  .Start = .Start + 2
  .ConvertToTable Separator:=vbTab, Numcolumns:=4, AutoFitBehavior:=wdAutoFitContent, AutoFit:=True
  With .Tables(1).Rows.First.Range
    .ParagraphFormat.Alignment = wdAlignParagraphCenter
    .Font.Bold = True
  End With
End With
 
Application.ScreenUpdating = True
End Sub
 
 
' I have no idea what this is doing??????????????
Function ParsePageRefs(StrPages As String)
Dim ArrTmp(), i As Integer, j As Integer, k As Integer
ReDim ArrTmp(UBound(Split(StrPages, ",")))
For i = 0 To UBound(Split(StrPages, ","))
  ArrTmp(i) = Split(StrPages, ",")(i)
Next
For i = 0 To UBound(ArrTmp) - 1
  If IsNumeric(ArrTmp(i)) Then
    k = 2
    For j = i + 2 To UBound(ArrTmp)
      If CInt(ArrTmp(i) + k) <> CInt(ArrTmp(j)) Then Exit For
      ArrTmp(j - 1) = ""
      k = k + 1
    Next
    i = j - 1
  End If
Next
ParsePageRefs = Replace(Replace(Replace(Replace(Join(ArrTmp, ","), ",,", " "), " ,", " "), "  ", " "), " ", "-")
End Function