Option Explicit

Private Const mc_MsgTitle As String = "VB-fun-Demo"

Sub WortSuchenUndSeitenzahlAusgeben()
  Dim objWDDoc      As Word.Document
  Dim intPagesCnt   As Integer

  Dim strFind       As String
  Dim intCntSum     As Integer
  Dim intCnt        As Integer

  Dim intPageNum    As Integer
  Dim aintFound()   As Integer

  Dim i             As Integer
  Dim strMsg        As String

  strFind = InputBox("Bitte geben Sie den Suchbegriff ein:", _
            Title:=mc_MsgTitle, Default:="Hallihallo...")

  If StrPtr(strFind) <> 0 Then
    If Len(strFind) > 0 Then
      Application.ScreenUpdating = False

      Set objWDDoc = ActiveDocument
      objWDDoc.Range(0, 0).Select
      objWDDoc.Repaginate

      intPagesCnt = objWDDoc.ComputeStatistics(wdStatisticPages)
      ReDim aintFound(1 To intPagesCnt)

      intCntSum = 0
      intCnt = 0
      intPageNum = 0

      With Selection.Find
        .ClearFormatting
        .Forward = True
        .MatchWholeWord = True
        .MatchCase = False
        .Wrap = wdFindContinue

        .Text = strFind
        .Execute

        While .Found = True
          intCntSum = intCntSum + 1
          If intPageNum = Selection.Information( _
                       wdActiveEndPageNumber) Then
            intCnt = intCnt + 1
          Else
            intCnt = 1
            intPageNum = Selection.Information( _
                           wdActiveEndPageNumber)
          End If
          aintFound(intPageNum) = intCnt
          .Execute
        Wend
      End With

      If intCntSum > 0 Then
        strMsg = "Der Suchbegriff '" & strFind & _
              "' kommt insgesamt " & CStr(intCntSum) & _
              " mal im Hauptteil des Dokumentes vor!" & _
              vbCrLf & vbCrLf

        For i = 1 To UBound(aintFound)
          If aintFound(i) > 0 Then
            strMsg = strMsg & CStr(aintFound(i)) & _
                  " mal auf Seite " & i & vbCrLf
          End If
        Next i

        strMsg = Mid(strMsg, 1, Len(strMsg) - 2)
        MsgBox strMsg, vbOKOnly + vbInformation, mc_MsgTitle

      Else
        MsgBox "Das Wort '" & strFind & "' kommt " & _
               "im Hauptteil des Dokumentes nicht vor!", _
               vbOKOnly + vbInformation, mc_MsgTitle
      End If

      objWDDoc.Range(0, 0).Select
      Application.ScreenUpdating = True

      Set objWDDoc = Nothing
    End If
  End If
End Sub