Public Sub DeleteDuplicatesCol2()
  Dim xTable As Table, xRow As Range, xStr As String, xDic As Object
  Dim I As Long, J As Long, KK As Long, xNum As Long, iRow As Long, iRows As Long
  Dim aRng As Range, cRng As Range, lWords As Long, lRows As Long, aCell As Cell

  'Application.ScreenUpdating = False
  Set xDic = CreateObject("Scripting.Dictionary")
  If Selection.Tables.Count = 0 Then
    MsgBox "Macro must be run when a table is selected"
    Exit Sub
  Else
    Set xTable = Selection.Tables(1)
    iRows = xTable.Rows.Count
    For I = iRows To 4 Step -1
      Set aRng = xTable.Cell(I, 2).Range
      For iRow = 4 To I - 1
        Set cRng = xTable.Cell(iRow, 2).Range
        If aRng.Text = cRng.Text Then
          xTable.Rows(I).Delete
          lRows = lRows + 1
          Exit For
        End If
      Next iRow
    Next I
  End If
  Set aRng = ActiveDocument.Range(xTable.Rows(4).Range.Start, xTable.Range.End)
  For Each aCell In aRng.Cells
    If aCell.ColumnIndex = 3 Then lWords = lWords + aCell.Range.Words.Count - 1
  Next aCell
  
  Application.ScreenUpdating = True
  MsgBox "Word count in column 3: " & lWords
End Sub