Count Lines of Text
(A Microsoft Word Help & Tip page by Gregory K. Maxey)

Option Explicit
Private m_lngUndo As Long
Private m_bUndo As Boolean
Private m_lngOffset As Long
Sub ReportLines()
  MsgBox fcnCountLinesOfText(Selection.Range)
  MsgBox fcnCountLinesOfText(ActiveDocument.Range)
lbl_Exit:
  Exit Sub
End Sub
Function fcnCountLinesOfText(oRng As Range) As Long
Dim oRngUndo As Range
  m_lngUndo = 0
  m_lngOffset = 0
  m_bUndo = False
  If oRng.Tables.Count = 0 Then
    With oRng.Find
      .ClearFormatting
      .Format = False
      .Forward = True
      .Wrap = wdFindStop
      .MatchWildcards = True
      .Text = "[^l^13]{2,}"
      .Replacement.Text = "^p"
      If .Execute(Replace:=wdReplaceAll) Then
        m_bUndo = True
        m_lngUndo = 1
      End If
    End With
    DoEvents
    fcnCountLinesOfText = oRng.ComputeStatistics(1)
    If m_bUndo Then ActiveDocument.Undo
    DoEvents
  Else
    Set oRngUndo = oRng.Duplicate
    With oRngUndo.Find
      .ClearFormatting
      .Format = False
      .Forward = True
      .Wrap = wdFindStop
      .MatchWildcards = True
      .Text = "[^l^13]{2,}"
      Do While .Execute
        m_bUndo = True
        m_lngUndo = m_lngUndo + 1
        oRngUndo.End = oRngUndo.End - 1
        oRngUndo.Delete
        oRngUndo.Collapse wdCollapseEnd
      Loop
    End With
    DoEvents
    m_lngUndo = m_lngUndo + fcnHandleTables(oRng)
    fcnCountLinesOfText = oRng.ComputeStatistics(wdStatisticLines) - m_lngOffset
    If m_bUndo Then ActiveDocument.Undo m_lngUndo
    DoEvents
  End If
lbl_Exit:
  Exit Function
End Function
Function fcnHandleTables(oRngEval As Range) As Long
Dim oTbl As Table
Dim oRng As Range
Dim lngUndo As Long
  For Each oTbl In oRngEval.Tables
    Set oRng = oTbl.Range
    oRng.Collapse wdCollapseStart
    On Error GoTo Reenter
    If oRng.Characters.First.Previous = vbCr Then
      If Len(oRng.Characters.First.Previous.Paragraphs(1).Range.Text) = 1 Then
        If oRng.Characters.First.Previous.Start = ActiveDocument.Range.Start Then
          oRng.Characters.First.Previous.Delete
          lngUndo = lngUndo + 1
          m_bUndo = True
        Else
          If Not oRng.Characters.First.Previous.Previous.Information(wdWithInTable) Then
            oRng.Characters.First.Previous.Delete
            lngUndo = lngUndo + 1
            m_bUndo = True
          End If
        End If
      End If
    End If
    Set oRng = oTbl.Range
    oRng.Collapse wdCollapseEnd
    Do While oRng.Characters.Last = vbCr
      If oRng.Characters.Last.InRange(oRngEval) Then
        If Not oRng.Characters.Last.End = ActiveDocument.Range.End Then
          If Not oRng.Characters.Last.Previous.Information(wdWithInTable) Then
            oRng.Characters.Last.Delete
            lngUndo = lngUndo + 1
            m_bUndo = True
          Else
            'Don't try to delete single paragraphs between tables. Just offset the count by 1.
            m_lngOffset = m_lngOffset + 1
            Exit Do
          End If
        Else
          Exit Do
        End If
      Else
        Exit Do
      End If
    Loop
Reenter:
  Next oTbl
  fcnHandleTables = lngUndo
lbl_Exit:
  Exit Function
End Function

Sub CountQualifiedLines()
Dim CharCount As Integer
Dim tCount As Integer
Dim LineCount As Integer
Dim Qualifier As String
  Qualifier = InputBox("Enter threshold line length." & vbCr + vbCr _
                     & "To be counted the line must contain the " _
                     & "threshold number of characters " _
                     & "(excluding the line end mark.)", _
                     "Line Length", 1)
  tCount = ActiveDocument.ComputeStatistics(wdStatisticLines)
  Selection.HomeKey wdStory
  Do While tCount > 0
    With Selection
      .EndKey Unit:=wdLine, Extend:=wdExtend
      CharCount = .Characters.Count
      tCount = tCount - 1
      On Error GoTo lbl_Exit
      If CharCount > Qualifier Then
        LineCount = LineCount + 1
      End If
      .Collapse wdCollapseStart
      .MoveDown Unit:=wdLine, Count:=1
      .EndKey Unit:=wdLine, Extend:=wdExtend
    End With
  Loop
  Selection.HomeKey wdStory
  MsgBox "There are " & LineCount & " qualified lines in this document"
lbl_Exit:
  Exit Sub
End Sub