Public Sub DeleteDuplicatesCol3()

  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
  Dim nWordsCount As Long
  Dim nCharCount As Long

  '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

nWordsCount = aRng.ComputeStatistics(wdStatisticWords)
nCharCount = aRng.ComputeStatistics(wdStatisticCharacters)
 
    Application.ScreenUpdating = True

    MsgBox "Word count in column 3: " & "The entire doc contains: " & vbCrLf & nWordsCount & " words and" & vbCrLf & _
           nCharCount & " characters without spaces", , "Word Count"

  End If

  
  End Sub