Sub CountWords()
Application.ScreenUpdating = False
Dim oTbl As Table, lTbl As Long, Sctn As Section
Dim oHdFt As HeaderFooter, lHdr As Long, lFtr As Long
Dim oEnt As Endnote, lEnt As Long
Dim oFnt As Footnote, lFnt As Long
Dim oShp As Shape, lShp As Long
Dim oPara As Paragraph, lCpt As Long
With ActiveDocument
  For Each oTbl In .Tables
    lTbl = lTbl + oTbl.Range.ComputeStatistics(wdStatisticWords)
  Next
  For Each oEnt In .Endnotes
    lEnt = lEnt + oEnt.Range.ComputeStatistics(wdStatisticWords)
  Next
  For Each oFnt In .Footnotes
    lFnt = lFnt + oFnt.Range.ComputeStatistics(wdStatisticWords)
  Next
  For Each Sctn In .Sections
    For Each oHdFt In Sctn.Headers
      If Not oHdFt.LinkToPrevious Then _
        lHdr = lHdr + oHdFt.Range.ComputeStatistics(wdStatisticWords)
    Next
    For Each oHdFt In Sctn.Footers
      If Not oHdFt.LinkToPrevious Then _
        lFtr = lFtr + oHdFt.Range.ComputeStatistics(wdStatisticWords)
    Next
  Next
  For Each oShp In .Endnotes
    If Not oShp.TextFrame Is Nothing Then _
      lShp = lShp + oShp.TextFrame.TextRange.ComputeStatistics(wdStatisticWords)
  Next
  For Each oPara In .Paragraphs
    If oPara.Style = "Caption" Then _
      lCpt = lCpt + oPara.Range.ComputeStatistics(wdStatisticWords)
  Next
  MsgBox "Word Count Statistics:" & vbCr & _
    "Tables - " & vbTab & vbTab & lTbl & vbCr & _
    "EndNotes - " & vbTab & lEnt & vbCr & _
    "Footnotes - " & vbTab & lFnt & vbCr & _
    "Headers - " & vbTab & vbTab & lHdr & vbCr & _
    "Footers - " & vbTab & vbTab & lFtr & vbCr & _
    "Shapes - " & vbTab & vbTab & lShp & vbCr & _
    "Captions - " & vbTab & lCpt & vbCr & _
    "Other - " & vbTab & vbTab & .Range.ComputeStatistics(wdStatisticWords) - lTbl - lCpt
End With
Application.ScreenUpdating = True
End Sub