#1
|
||||
|
||||
Need macro to make list of "defined terms"
Need a Word macro that will automatically search for "defined terms" in a legal document (words or phrases in "quote marks") and make a list of them and the page numbers on which they can be found.
The resulting list would ideally have two columns on the page, and each column would look like the following: Affiliate . . . . . . . . . 50 | Property . . . . . . . 3, 56 Assignment . . . ..60, 65 | Seller . . . . . . . . . . . 1 Buyer . . . . . . . . . . . 1 | Transfer . . . . . . . . . 34 Completion Date . . . 23 | and so on. I have no Word macro skills. I actually wrote this macro for WordPerfect twelve years ago (long lost), but the complexities of Word macros are way beyond me. Our version of Office is 2003, and my OS is XP Pro SP3. Thanks. Last edited by glnz; 04-05-2012 at 02:25 PM. |
#2
|
||||
|
||||
Cross-posted at: http://social.technet.microsoft.com/...9-316f76abbe13
For cross-posting etiquette, please read: http://www.excelguru.ca/content.php?184 The following macro checks the contents of a document for expressions contained in a list of expressions in a separate document. These terms are then tallied and their page references output to a table at the end of the active document, showing the page #s on which they occur. The number of columns for the table is determined by the lCol variable. As coded, the output table uses an across-then-down layout. The table produced by the macro will only include those terms that are actually found in the active document. You will need to change 'Drive:\FilePath\KeyTerms.doc' to point to your own 'key terms' document. Note: The macro calls the ‘ParseNumSeq’ function found at the end of this post. Code:
Sub TabulatePredefinedKeyTerms() 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 Const lCol As Long = 2 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 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 j = 0 Do While .Find.Found If j <> .Duplicate.Information(wdActiveEndPageNumber) Then j = .Duplicate.Information(wdActiveEndPageNumber) StrPages = StrPages & j & " " End If .Find.Execute Loop StrPages = Replace(Trim(StrPages), " ", ",") If StrPages <> "" Then If i Mod lCol = lCol - 1 Then StrBreak = vbTab Else StrBreak = vbCr StrOut = StrOut & strFnd & vbTab & ParseNumSeq(StrPages, "&") & StrBreak End If End With NullString: Next i Set Rng = Doc.Range.Characters.Last With Rng .InsertAfter vbCr & Chr(12) & StrOut .Start = .Start + 2 .ConvertToTable Separator:=vbTab, Numcolumns:= lCol*2, 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 Note: The macro calls the ‘ParseNumSeq’ function found at the end of this post. Code:
Sub TabulateUndefinedKeyTerms() Application.ScreenUpdating = False ' This macro checks the contents of a document for expressions bounded by double-quotes. ' These terms are then tallied and their page references output to a table at the end ' of the document, showing the page #s on which they occur. ' The number of columns for the table is determined by the lCol variable. ' Optional code where the output table is created allows the user to choose ' between an across then down or down the across table layout. Dim Doc As Document, Rng As Range, Tbl As Table Dim StrTerms As String, strFnd As String, StrPages As String Dim StrOut As String, StrBreak As String, StrBkMk As String Dim i As Long, j As Long, lCol As Long StrPages = "": lCol = 2: StrBkMk = "_Defined_Terms": StrPages = "": StrTerms = vbCr Set Doc = ActiveDocument 'Go through the document looking for defined terms. With Doc.Content 'Check whether our table exists. If so, delete it. If .Bookmarks.Exists(StrBkMk) Then .Bookmarks(StrBkMk).Range.Tables(1).Delete With .Find .ClearFormatting .Replacement.ClearFormatting 'Ensure all double quotes are properly formatted, 'assuming that 'smart quotes' are in use. .Text = "[" & ChrW(8220) & Chr(147) & Chr(34) & Chr(148) & ChrW(8221) & "]" .Replacement.Text = """" .Format = False .Wrap = wdFindStop .MatchWholeWord = True .MatchWildcards = True .MatchCase = False .Execute Replace:=wdReplaceAll 'Find terms between matched pairs of double quotes, 'assuming that 'smart quotes' are in use. .Text = "[" & ChrW(8220) & Chr(147) & "]*[" & Chr(148) & ChrW(8221) & "]" .Execute End With Do While .Find.Found Set Rng = .Duplicate With Rng 'If it's not in the StrTerms list, add it. If InStr(StrTerms, vbCr & .Text & vbCr) = 0 Then StrTerms = StrTerms & .Text & vbCr End With .Find.Execute Loop End With 'Exit if no defined terms have been found. If StrTerms = vbCr Then MsgBox "No defined terms found." & vbCr & "Aborting.", vbExclamation, "Defined Terms Error" GoTo ErrExit End If 'Sort the key terms Set Rng = ActiveDocument.Range.Characters.Last With Rng .Collapse wdCollapseEnd .InsertBefore vbCr .InsertAfter StrTerms .Sort ExcludeHeader:=True, FieldNumber:=1, SortFieldType:=wdSortFieldAlphanumeric, _ SortOrder:=wdSortOrderAscending StrTerms = .Text .Text = vbNullString End With While Left(StrTerms, 1) = vbCr StrTerms = Mid(StrTerms, 2, Len(StrTerms) - 1) Wend 'Build the page records for all terms in the StrTerms list. For i = 0 To UBound(Split(StrTerms, vbCr)) - 1 strFnd = Trim(Split(StrTerms, vbCr)(i)) StrPages = "" With Doc.Content With .Find .ClearFormatting .Replacement.ClearFormatting .Format = False .Text = strFnd .Wrap = wdFindStop .MatchWholeWord = True .MatchWildcards = False .MatchCase = True .Execute End With j = 0 Do While .Find.Found 'If we haven't already found this term on this page, add it to the list. If j <> .Duplicate.Information(wdActiveEndAdjustedPageNumber) Then j = .Duplicate.Information(wdActiveEndAdjustedPageNumber) StrPages = StrPages & j & " " End If .Find.Execute Loop 'Turn the pages list into a comma-separated string. StrPages = Replace(Trim(StrPages), " ", ",") If StrPages <> "" Then 'Add the current record to the output list (StrOut) StrOut = StrOut & strFnd & vbTab & Replace(Replace(ParseNumSeq(StrPages, "&"), ",", ", "), " ", " ") & vbCr End If End With Next i 'Strip off the double quotes StrOut = Replace(Replace(StrOut, "“", ""), "”", "") 'Output the found terms as a table at the end of the document. With Rng 'Calculate the number of table lines for the data. j = -Int((UBound(Split(StrOut, vbCr))) / -lCol) Set Tbl = ActiveDocument.Tables.Add(Range:=Rng, NumRows:=j + 1, NumColumns:=lCol) With Tbl 'Define the overall table layout. With .Range.ParagraphFormat .RightIndent = CentimetersToPoints(5 / lCol) With .TabStops .ClearAll .Add Position:=CentimetersToPoints(15 / lCol), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots End With End With 'Populate & format the header row. For i = 1 To lCol With .Cell(1, i).Range .Text = "Term" & vbTab & "Pages" .ParagraphFormat.KeepWithNext = True End With Next With .Rows.First 'Apply the heading row attribute so that the table header repeats after a page break. .HeadingFormat = True 'Delete the header row's tab leaders. With .Range With .ParagraphFormat.TabStops .ClearAll .Add Position:=CentimetersToPoints(15 / lCol), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderSpaces End With .Font.Bold = True End With End With For i = 0 To UBound(Split(StrOut, vbCr)) - 1 ' Populate the data rows, down then across .Cell(i Mod j + 2, -Int(-(i + 1) / j)).Range.Text = Split(StrOut, vbCr)(i) ' Populate the data rows, across then down '.Range.Cells(i + lCol + 1).Range.Text = Split(StrOut, vbCr)(i) Next 'Bookmark the table. ActiveDocument.Bookmarks.Add Name:=StrBkMk, Range:=Tbl.Range End With End With 'Clean up and exit. ErrExit: Set Rng = Nothing: Set Tbl = Nothing: Set Doc = Nothing Application.ScreenUpdating = True End Sub Code:
Function ParseNumSeq(StrNums As String, Optional StrEnd As String) 'This function converts multiple sequences of 3 or more consecutive numbers in a ' list to a string consisting of the first & last numbers separated by a hyphen. ' The separator for the last sequence can be set via the StrEnd variable. Dim ArrTmp(), i As Long, j As Long, k As Long ReDim ArrTmp(UBound(Split(StrNums, ","))) For i = 0 To UBound(Split(StrNums, ",")) ArrTmp(i) = Split(StrNums, ",")(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 - 2 End If Next StrNums = Join(ArrTmp, ",") StrNums = Replace(Replace(Replace(StrNums, ",,", " "), ", ", " "), " ,", " ") While InStr(StrNums, " ") StrNums = Replace(StrNums, " ", " ") Wend StrNums = Replace(Replace(StrNums, " ", "-"), ",", ", ") If StrEnd <> "" Then i = InStrRev(StrNums, ",") If i > 0 Then StrNums = Left(StrNums, i - 1) & Replace(StrNums, ",", " " & Trim(StrEnd), i) End If End If ParseNumSeq = StrNums End Function
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
The comment for the function code says the following:
Quote:
Can you explain further how I would change the separators in the table's page references, so instead of this: 1-13 & 15 I'd can have this: 1-13, and 15 TIA, KS |
#4
|
||||
|
||||
That is achived via the call to the ParseNumSeq function found in the TabulateUndefinedKeyTerms macro. Change:
Code:
StrOut = StrOut & strFnd & vbTab & Replace(Replace(ParseNumSeq(StrPages, "&"), ",", ", "), " ", " ") & vbCr Code:
StrOut = StrOut & strFnd & vbTab & Replace(Replace(ParseNumSeq(StrPages, "and"), ",", ", "), " ", " ") & vbCr
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
Thanks. That worked as expected. Appreciate it. One quick follow up question
What do I need to change to get a list that looks like this: 1-3, 9, 12 If I insert a comma in the code like this (StrPages, ","), replacing the "and" or "&"), I get this: 1-3, 9 , 12 What to I need to change to eliminate that space before the comma? TIA, KS |
#6
|
||||
|
||||
Simply use:
Code:
StrOut = StrOut & strFnd & vbTab & Replace(Replace(ParseNumSeq(StrPages), ",", ", "), " ", " ") & vbCr
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#7
|
|||
|
|||
Excellent, thank you. That worked as expected for the undefined terms macro, but the code in the defined terms macro looks a little bit different and I'm not sure how/where I would change it to get the same outcome.
Apologies in advance if I wasn't clear enough in framing my question. KS |
#8
|
||||
|
||||
In that code, change:
StrOut = StrOut & strFnd & vbTab & ParseNumSeq(StrPages, "&") & StrBreak to: StrOut = StrOut & strFnd & vbTab & ParseNumSeq(StrPages) & StrBreak
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#9
|
|||
|
|||
Thanks. That worked. Appreciate your help!
KS |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Mailing: how to make the "page number" in Word is the same as "row number" in excel w | Jamal NUMAN | Word | 1 | 09-03-2011 11:37 AM |
How to choose a "List" for certain "Heading" from "Modify" tool? | Jamal NUMAN | Word | 2 | 07-03-2011 03:11 AM |
How the "Style" and the "List" are linked?? | Jamal NUMAN | Word | 1 | 06-30-2011 05:18 PM |
Is there a way to make the cross-refernce format to be "Only lable and number"? | Jamal NUMAN | Word | 1 | 04-10-2011 03:31 PM |
Make "Keep Text Only" the default past option in PP2003 | powerpointbry | PowerPoint | 0 | 09-17-2010 12:48 AM |