Es soll hier glaube ich ja sowieso nur das erste markiert werden!?
Ne, es sollen alle weiteren Vorkommen des gleichen Worts markiert werden.
Sind mehrere Wörter gleich einfach/kompliziert, soll wiederum das im Text erste davon bei allen Vorkommen gefärbt werden
Darum steht bei 'cm' in Klammern auch 3x. 'cm' ist das einfachste Wort im Text und kommt 3x vor.
Hab hier noch eine Alternative erstellt - mir war gestern langweilig. Da ist dieser Teil der Aufgabe mit enthalten.
Option Explicit
Sub Test_Alternative()
Dim rngWord As Word.Range
Dim colMin As VBA.Collection
Dim colMax As VBA.Collection
Dim k_min As Long
Dim k_max As Long
Dim k As Long
'Formatierung aus vorherigen Durchgang rückgängig machen
ThisDocument.Range.Font.Reset
ThisDocument.Range.HighlightColorIndex = wdAuto
'Wortweise durch den Text bewegen
For Each rngWord In ThisDocument.Words
'Leerzeichen am Ende eines Wortes weglassen - seltsames Verhalten von Word ¯\_('-')_/¯
rngWord.MoveEndWhile " ", wdBackward
'unsere Hilfsfunktion aufrufen (siehe unten)
k = Complexness(rngWord.Text)
If k > 0 Then
If k < k_min Or k_min = 0 Then
' If Not colMin Is Nothing _
' Then Debug.Print "[k_min]"; Tab(12); "*entfernt*"
'
' Debug.Print "[k_min]"; Tab(12); "*neu*"; Tab(24); "'"; rngWord.Text; "'"
k_min = k
Set colMin = New VBA.Collection
Call colMin.Add(rngWord, rngWord.Text)
ElseIf k = k_min Then
'wenn es sich um das gleiche (identische) Wort handelt
'nehmen wir es mit auf
On Error Resume Next
Call colMin(rngWord.Text)
If Err.Number = 0 Then
' Debug.Print "[k_min]"; Tab(12); "+1"; Tab(24); "'"; rngWord.Text; "'"
Call colMin.Add(rngWord)
End If
On Error GoTo 0
End If
If k > k_max Or k_max = 0 Then
' If Not colMax Is Nothing _
' Then Debug.Print "[k_max]"; Tab(12); "*entfernt*"
'
' Debug.Print "[k_max]"; Tab(12); "*neu*"; Tab(24); "'"; rngWord.Text; "'"
k_max = k
Set colMax = New VBA.Collection
Call colMax.Add(rngWord, rngWord.Text)
ElseIf k = k_max Then
'wenn es sich um das gleiche (identische) Wort handelt
'nehmen wir es mit auf
On Error Resume Next
Call colMax(rngWord.Text)
If Err.Number = 0 Then
' Debug.Print "[k_max]"; Tab(12); "+1"; Tab(24); "'"; rngWord.Text; "'"
Call colMax.Add(rngWord)
End If
On Error GoTo 0
End If
' Else
' Debug.Print Tab(12); "*ignoriert*"; Tab(24); "'"; rngWord.Text; "'"
End If 'k > 0
Next
For Each rngWord In colMin
rngWord.HighlightColorIndex = WdColorIndex.wdGreen
rngWord.Font.ColorIndex = WdColorIndex.wdWhite
Next
For Each rngWord In colMax
rngWord.HighlightColorIndex = WdColorIndex.wdRed
rngWord.Font.ColorIndex = WdColorIndex.wdWhite
Next
End Sub
'Hilfsfunktion
' - Alternative mit Mid()- und InStr()-Funktion
' stellt fest wie kompliziert/komplex ein Wort ist
Private Function Complexness(Word As String) As Long
Dim strChr As String * 1
Dim i As Long
Dim k As Long
For i = 1 To Len(Word)
strChr = Mid$(Word, i, 1)
Select Case strChr
Case "a" To "z", "A" To "Z", "ä", "ö", "ü", "Ä", "Ö", "Ü", "ß"
If InStr(Mid$(Word, 1, i - 1), strChr) = 0 Then
k = k + 1
End If
End Select
Next
Complexness = k
End Function
Was die Sache mit Ribbon angeht: Da solltest du deine Aufzeichnungen ansehen; ich gehe auf das Thema hier nicht weiter ein - der Löwenanteil der Aufgabe ist das Makro oben.
Grüße
|