Hamburg (amtlich Freie und Hansestadt Hamburg (niederdeutsch Friee un Hansestadt Hamborg, Ländercode: HH), ist als Stadtstaat ein Land der Bundesrepublik Deutschland. Der amtliche Name verweist auf die Geschichte Hamburgs als Freie Reichsstadt und als führendes Mitglied des Handelsbundes der Hanse.

 

Hamburg ist mit ca. 1,9 Millionen Einwohnern die zweitgrößte Stadt Deutschlands und die drittgrößte im deutschen Sprachraum. Das Stadtgebiet ist in sieben Bezirke und 104 Stadtteile gegliedert, darunter mit dem Stadtteil Neuwerk eine in der Nordsee gelegene Inselgruppe.

Anmerkung: Der Beispieltext hat Rechtschreibfehler: (aufgrund Einscannen (OCR)?)

Option Explicit

Sub Test_AllInOne()
  
  Dim rngWord     As Word.Range
  Dim rngLaengste As Word.Range
  Dim dic         As Object 'Scripting.Dictionary
  Dim nGrossb     As Long
  
  'Formatierung aus vorherigen Durchgang rückgängig machen
  ThisDocument.Range.Font.Reset
  ThisDocument.Range.HighlightColorIndex = wdAuto
  
  'hiermit merken wir uns wie oft ein Wort vorkommt (und auch wo im Text)
  ' dic
  ' + Item("Hamburg") : Scripting.Dictionary-Objekt
  '   + #0: Objekt    : Word.Range-Objekt
  '   + #1: Objekt    : Word.Range-Objekt
  '   + #2: Objekt    : Word.Range-Objekt
  ' + Item("amtlich") : Scripting.Dictionary-Objekt
  '   + #0: Objekt    : Word.Range-Objekt
  ' usw.
  Set dic = CreateObject("Scripting.Dictionary")
  'wir unterscheiden Groß-/Kleinschreibung (z.B. 'A' ungleich 'a')
  dic.CompareMode = VbCompareMethod.vbBinaryCompare
  
  'Wortweise durch den Text bewegen
  For Each rngWord In ThisDocument.Words
    
    'Leerzeichen am Ende eines Wortes weglassen - seltsames Verhalten von Word ¯\_('-')_/¯
    rngWord.MoveEndWhile " ", wdBackward
    
    'Kommas, Klammern, usw. interessieren uns hier nicht
    If IsWord(rngWord.Text) Then
      
'#1: Anzahl der Großbuchstaben zählen
      nGrossb = nGrossb + AnzGrossbuchstaben(rngWord.Text)
      
'#2: hier merken wir uns das längste Wort in einem Word.Range-Objekt
      If rngLaengste Is Nothing Then
        Set rngLaengste = rngWord
'        Debug.Print Len(rngWord), rngWord.Text
      ElseIf Len(rngWord.Text) > Len(rngLaengste.Text) Then
        Set rngLaengste = rngWord
'        Debug.Print Len(rngWord), rngWord.Text
      End If

'#3: alle Worte merken - Wort-Liste (siehe oben)
      If Not dic.Exists(rngWord.Text) Then
      'neues Wort aufnehmen (siehe oben)
        Call dic.Add(rngWord.Text, CreateObject("Scripting.Dictionary"))
        With dic(rngWord.Text)
          Call .Add(.Count, rngWord)
        End With
      Else
      'bereits bekanntes Wort in Liste -> Word.Range merken
        With dic(rngWord.Text)
          Call .Add(.Count, rngWord)
        End With
      End If
      
    End If 'IsWord()
    
  Next 'rngWord
  
'#1: Anzahl der Großbuchstaben ausgeben
  Call MsgBox("Anzahl Großbuchstaben: " & nGrossb, vbInformation)
  
'#2: längstes Wort im Text markieren
  With rngLaengste
    .HighlightColorIndex = WdColorIndex.wdRed
    .Font.ColorIndex = WdColorIndex.wdWhite
  End With

'#3 Häufigstes vorkommen ermitteln (Wort-Liste mit größter Anzahl an Word.Range-Objekten)
  Dim vntElem   As Variant
  Dim strKey    As String
  Dim n         As Long
  
  For Each vntElem In dic
'    Debug.Print dic(vntElem).Count, vntElem
    If dic(vntElem).Count > n Then
      n = dic(vntElem).Count
      strKey = vntElem
    End If
  Next
  
  If strKey <> "" Then
    With dic(strKey)
      'vntElem ist ein Word.Range-Objekt
      For Each vntElem In .Items()
        vntElem.HighlightColorIndex = WdColorIndex.wdGreen
        vntElem.Font.ColorIndex = WdColorIndex.wdWhite
      Next
    End With
  End If
  
End Sub

Private Function IsWord(Word As String) As Boolean
  
  Dim blnFlag As Boolean
  Dim strChr  As String * 1
  Dim i       As Long
  
  blnFlag = True
  
  For i = 1 To Len(Word)
    strChr = Mid$(Word, i, 1)
    Select Case LCase$(strChr)
      Case "a" To "z", "ä", "ö", "ü", "ß"
        'ok
      Case Else
        blnFlag = False
        Exit For
    End Select
  Next
  
  IsWord = blnFlag
  
End Function

'Hilfsfunktion
' - Alternative mit Mid()- und InStr()-Funktion
' stellt fest wie kompliziert/komplex ein Wort ist
Private Function AnzGrossbuchstaben(Wort As String) As Long
  
  Dim strChr  As String * 1
  Dim i       As Long
  Dim n       As Long
  
  For i = 1 To Len(Wort)
    strChr = Mid$(Wort, i, 1)
    Select Case strChr
      Case "A" To "Z", "Ä", "Ö", "Ü"
        n = n + 1
    End Select
  Next
  
  AnzGrossbuchstaben = n

End Function