Option Explicit
Private mName As String
Private mCount As Long
Private mPage As String

Public Property Get Name() As String
'The Property Get procedure passes a class property value to a calling Sub or
'Function.
  Name = mName
End Property
Public Property Let Name(NewValue As String)
'The Property Let procedure allows the passing Sub or Function to assign a value to the
'Class property mName.  It must have same name i.e., Let Name as its corresponding
'Property Get Name procedure above.
  mName = NewValue
End Property
Public Property Get PagNum() As String
'The Property Get procedure passes a class property value to a calling Sub or
'Function.
  PagNum = mPage
End Property
Public Property Let PagNum(NewValue As String)
'The Property Let procedure allows the passing Sub or Function to assign a value to the
'Class property mName.  It must have same name i.e., Let Name as its corresponding
'Property Get Name procedure above.
  mPage = NewValue
End Property


Public Property Get Count() As Long
  Count = mCount
End Property
Public Property Let Count(NewValue As Long)
  mCount = NewValue
End Property

Option Explicit
Sub SpellingErrorReport()


Dim oError As clsError                  'clsError is the class module name
                                        'each unique spelling error will be an
                                        'instance in the class module
Dim colErrors As Collection             'Collection of unique spelling errors
Dim oSpErrors As ProofreadingErrors
Dim oSpError As Word.Range
Dim oSpErrorCnt As Integer              'Number of total misspelled words
Dim uniqueSPErrors As Integer           'Number of unique misspelled words
Dim bolSortByFreq As Boolean            'Flag for sorting order
Dim j As Integer                        'Temp values for sorting
Dim k As Integer
Dim l As Integer
Dim tempCount As Integer
Dim tempString As String
Dim oRng As Word.Range
Dim oTbl As Table

Set colErrors = New Collection
Set oSpErrors = ActiveDocument.Range.SpellingErrors

'Set sort order
bolSortByFreq = True
If MsgBox("The default sort order is error freqeuncy." _
        & vbCr & "Do you want to sort errors" _
        & " alphabetically instead?", vbYesNo) = vbYes Then
  bolSortByFreq = False
End If

For Each oSpError In oSpErrors
On Error Resume Next
  'Sets oError to the value of colErrors(Misspelled Word)
  'if it already exist in collection
  Set oError = colErrors(oSpError.Text)
  'If it doesn't exist in colErrors then oError remains set to Nothing
On Error GoTo 0
'Not in the collection then create new Class instance and add error to colErrors
If oError Is Nothing Then
  'Create new Class instance
  Set oError = New clsError
  'Call Property Let Procedure in Class module and pass value to .Name property
  oError.Name = oSpError.Text
  If oError.PagNum = vbNullString Then
    oError.PagNum = oSpError.Information(wdActiveEndPageNumber)
  End If
  'Add to colError.  Calls Propert Get Procedure in Class module to retrieve .Name value
  colErrors.Add oError, oError.Name
End If

'Increment count
oError.Count = oError.Count + 1
Set oError = Nothing
Next

'Sort for Display
For j = 1 To colErrors.Count - 1
  k = j
  For l = j + 1 To colErrors.Count
    If (Not bolSortByFreq And colErrors(l).Name < colErrors(k).Name) _
        Or (bolSortByFreq And colErrors(l).Count > colErrors(k).Count) Then k = l
  Next l
    If k <> j Then
      tempString = colErrors(j).Name
      colErrors(j).Name = colErrors(k).Name
      colErrors(k).Name = tempString
      tempCount = colErrors(j).Count
      colErrors(j).Count = colErrors(k).Count
      colErrors(k).Count = tempCount
    End If
Next j

'Display Results
oSpErrorCnt = ActiveDocument.Range.SpellingErrors.Count
uniqueSPErrors = colErrors.Count

Set oRng = ActiveDocument.Range
oRng.Move
oRng.InsertBreak wdSectionBreakNextPage
oRng.Select
Selection.ParagraphFormat.TabStops.ClearAll
With Selection
For Each oError In colErrors
  .TypeText Text:=oError.Name & vbTab & oError.PagNum & vbTab & oError.Count & vbCrLf
Next
End With
Selection.Sections(1).Range.Select
Selection.ConvertToTable
Selection.Collapse wdCollapseStart

Set oTbl = Selection.Tables(1)

oTbl.Rows.Add BeforeRow:=Selection.Rows(1)
oTbl.Cell(1, 1).Range.InsertBefore "Spelling Error"
oTbl.Cell(1, 2).Range.InsertBefore "PFO"
oTbl.Cell(1, 3).Range.InsertBefore "# Occurrences"
oTbl.Columns(3).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
Selection.Collapse wdCollapseStart
oTbl.Rows(1).Shading.BackgroundPatternColor = wdColorGray20
oTbl.Columns(1).PreferredWidth = InchesToPoints(4.5)
oTbl.Columns(2).PreferredWidth = InchesToPoints(1)
oTbl.Columns(3).PreferredWidth = InchesToPoints(1)


oTbl.Rows.Add
oTbl.Cell(oTbl.Rows.Count, 1).Range.InsertBefore "Summary"
oTbl.Cell(oTbl.Rows.Count, 3).Range.InsertBefore "Total"
oTbl.Rows(oTbl.Rows.Count).Shading.BackgroundPatternColor = wdColorGray20

oTbl.Rows.Add
oTbl.Cell(oTbl.Rows.Count, 1).Range.InsertBefore "Number of Unique Misspellings"
oTbl.Cell(oTbl.Rows.Count, 3).Range.InsertBefore Trim(Str(uniqueSPErrors))
oTbl.Rows(oTbl.Rows.Count).Shading.BackgroundPatternColor = wdColorAutomatic

oTbl.Rows.Add
oTbl.Cell(oTbl.Rows.Count, 1).Range.InsertBefore "Total Number of Spelling Errors"
oTbl.Cell(oTbl.Rows.Count, 3).Range.InsertBefore Trim(Str(oSpErrorCnt))

Selection.HomeKey wdStory

End Sub