I would prefer to have it append the new data at the end of the source document.
Also, would like it to consolidate the CCI page numbers i.e. if CCI 1234 is found on pages 3,6, and 9 I would like the table to show CCI 1234 once with 4 page numbers versus 4 separate entries.
TIA for any assistance.
Code:
Sub Find_CCI()
'
' Find CCI Numbers Macro
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strCci As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Title = "Extract CCI List to New Document"
'Show msg - stop if user does not click Yes
Msg = "Do you want to continue?"
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
'Start a string to be used for storing names of Ccis found
strAllFound = "#"
Set oDoc_Source = ActiveDocument
'Create new document for CCIs
Set oDoc_Target = Documents.Add
With oDoc_Target
'Make sure document is empty
.Range = ""
'Insert info in header - change date format as you wish
.PageSetup.TopMargin = CentimetersToPoints(3)
.Sections(1).Headers(wdHeaderFooterPrimary).Range.text = _
"CCIs extracted from: " & oDoc_Source.FullName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 12
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for CCI, definition, and page number
Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
With oTable
'Format the table a bit
' Add borders to cells
With oTable.Rows(1).Cells.Borders
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
End With
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.text = "CCI Number"
.Cell(1, 2).Range.text = "Definition"
.Cell(1, 3).Range.text = "Page Number"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 20
.Columns(3).PreferredWidth = 10
.Columns(3).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
End With
With oDoc_Source
Set oRange = .Range
n = 1 'used to count below
With oRange.Find
'Use wildcard search to find CCI Numbers
.text = "\(CCI*\)"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWildcards = True
'Perform the search
Do While .Execute
'Continue while found
strCci = oRange
'Insert in target doc
'If strCci is already in strAllFound, do not add again
'If InStr(1, strAllFound, "#" & strCci & "#") = 0 Then '''''
'Add new row in table from second CCI
If n > 1 Then oTable.Rows.Add
'Was not found before
strAllFound = strAllFound & strCci & "#"
'Insert in column 1 in oTable
'Compensate for heading row
With oTable
.Cell(n + 1, 1).Range.text = strCci
'Insert page number in column 3
.Cell(n + 1, 3).Range.text = oRange.Information(wdActiveEndPageNumber)
End With
n = n + 1
' End If ''''
Loop
End With
End With
'Sort the CCIs numerically - skip if only 1 found
If n > 2 Then
With Selection
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
Application.ScreenUpdating = True
'If no CCIs found, show msg and close new document without saving
'Else keep open
If n = 1 Then
Msg = "No CCI references found."
oDoc_Target.Close savechanges:=wdDoNotSaveChanges
Else
Msg = "Finished extracting " & n - 1 & " CCI(s) to a new document."
End If
MsgBox Msg, vbOKOnly, Title
'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
End Sub