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
ThisDocument.Range.Font.Reset
ThisDocument.Range.HighlightColorIndex = wdAuto
For
Each
rngWord
In
ThisDocument.Words
rngWord.MoveEndWhile
" "
, wdBackward
k = Complexness(rngWord.Text)
If
k > 0
Then
If
k < k_min
Or
k_min = 0
Then
k_min = k
Set
colMin =
New
VBA.Collection
Call
colMin.Add(rngWord, rngWord.Text)
ElseIf
k = k_min
Then
On
Error
Resume
Next
Call
colMin(rngWord.Text)
If
Err.Number = 0
Then
Call
colMin.Add(rngWord)
End
If
On
Error
GoTo
0
End
If
If
k > k_max
Or
k_max = 0
Then
k_max = k
Set
colMax =
New
VBA.Collection
Call
colMax.Add(rngWord, rngWord.Text)
ElseIf
k = k_max
Then
On
Error
Resume
Next
Call
colMax(rngWord.Text)
If
Err.Number = 0
Then
Call
colMax.Add(rngWord)
End
If
On
Error
GoTo
0
End
If
End
If
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
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