Microsoft Office Forums - View Single Post - [Solved] Macro to return a word count of text contained within a bookmark

gmayor · 08-21-2016, 05:43 AM

In theory that is straightforward, though your idea of what constitues a 'word' to be counted my not coincide with Word's

Code:

Option Explicit

Sub Macro1()
Dim oTable As Table
Dim oRng As Range
Dim oBM As Range
    Set oTable = ActiveDocument.Tables(ActiveDocument.Tables.Count)
    If InStr(oTable.Cell(1, 1).Range.Text, "Bookmark") = 0 Then
        Set oRng = ActiveDocument.Range
        oRng.Collapse 0
        Set oTable = ActiveDocument.Tables.Add(oRng, 4, 2)
        Set oRng = oTable.Cell(1, 1).Range
        oRng.End = oRng.End - 1
        oRng.Text = "Bookmark"
        oRng.Font.Bold = True
        Set oRng = oTable.Cell(1, 2).Range
        oRng.End = oRng.End - 1
        oRng.Text = "Word Count"
        oRng.Font.Bold = True
        Set oRng = oTable.Cell(2, 1).Range
        oRng.End = oRng.End - 1
        oRng.Text = "Sustainability"
        oRng.Font.Bold = True
        Set oRng = oTable.Cell(3, 1).Range
        oRng.End = oRng.End - 1
        oRng.Text = "Team Working"
        oRng.Font.Bold = True
        Set oRng = oTable.Cell(4, 1).Range
        oRng.End = oRng.End - 1
        oRng.Text = "Total"
        oRng.Font.Bold = False
        oTable.Rows(2).Shading.BackgroundPatternColor = &HD8EFE1
        oTable.Rows(4).Shading.BackgroundPatternColor = &HD8EFE1
    End If
    Set oBM = ActiveDocument.Bookmarks("Sustainability").Range
    Set oRng = oTable.Cell(2, 2).Range
    oRng.End = oRng.End - 1
    oRng.Text = oBM.Words.Count
    oRng.Font.Bold = False
    Set oBM = ActiveDocument.Bookmarks("TeamWorking").Range
    Set oRng = oTable.Cell(3, 2).Range
    oRng.End = oRng.End - 1
    oRng.Text = oBM.Words.Count
    oRng.Font.Bold = False
    Set oRng = oTable.Cell(4, 2).Range
    oRng.End = oRng.End - 1
    oRng.Text = ""
    ActiveDocument.Fields.Add oRng, wdFieldExpression, "SUM(ABOVE)", False
lbl_Exit:
    Set oTable = Nothing
    Set oRng = Nothing
    Set oBM = Nothing
    Exit Sub
End Sub