Option Explicit
Type myNameJahreszahl_structure
s_Name As String
s_Jahreszahl As String
End Type
'**********************************************************
Sub NamenFormatKapitaelchenSuchenUndAufAnhaengendeJahreszahlUntersuchen()
->Voraussetzungen:
-> die Namen sind als Kapitälchen formatiert
-> es gibt keinen anderweitigen Text mit Formatierung Kapitälchen
->*****
-> anhängende Jahreszahlen
-> zul. Zeichen: 0 bis 9 ( )
-> die den Namen folgenden Zeichen werden auf eine Form untersucht
-> 1999
-> (1999)
-> Leerstellen werden dabei nicht mitbetrachtet
->****
-> die gefundenen Namen und wenn vorhanden die folgende Jahreszahl
-> werden in einem neuen Dokument alphabetisch geordnet ausgegeben
->****
Const c_LENMAX_TEXTJAHRESZAHL = 10
Dim doc As Document
Dim l_StartName_anf As Long, l_StartName_end As Long
Dim l_StartSave_anf As Long, l_StartSave_end As Long
Dim l_PosEnd As Long, l_pos As Long
Dim f_NJ() As myNameJahreszahl_structure, f_NJ_cnt As Long
Dim s_tmp As String
->Feld Name,Jahreszahl initialisieren
ReDim f_NJ(1 To 1): f_NJ_cnt = 0
Set doc = ActiveDocument
->Suchbereichsende setzen
l_PosEnd = doc.Content.End
Do
->Kapitälchen suchen, vom Ende rückwärts
Selection.Start = doc.Content.Start
Selection.End = l_PosEnd
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Forward = False
.Wrap = wdFindStop
.Text = ^?
.Font.SmallCaps = True
If .Execute() = False Then Exit Do->nichts gefunden ?
End With
->Position merken
l_StartName_anf = Selection.Start
l_StartName_end = Selection.End
->Zeichen davor auch Kapitälchen ?
l_pos = l_StartName_anf - 1
Do
If l_pos < 0 Then Exit Do->alles erledigt ?
If doc.Range(Start:=l_pos, _
End:=l_pos + 1).Font.SmallCaps = False Then Exit Do
->Start-Position erweitern
l_StartName_anf = l_pos
l_pos = l_pos - 1
Loop
Selection.Start = l_StartName_anf
->Feld Name,Jahreszahl um einen Eintrag vergrößern
f_NJ_cnt = f_NJ_cnt + 1: ReDim Preserve f_NJ(1 To f_NJ_cnt)
doc.Range(Start:=l_StartName_anf, End:=l_StartName_end).Select
f_NJ(f_NJ_cnt).s_Name = Trim(doc.Range(Start:=l_StartName_anf, End:=l_StartName_end).Text)
->anschließenden Text auf Jahreszahl untersuchen
Selection.Start = l_StartName_end
Selection.End = l_StartName_end + c_LENMAX_TEXTJAHRESZAHL
s_tmp = Selection.Text
f_NJ(f_NJ_cnt).s_Jahreszahl = _
NachfolgendenTextAufJahreszahlUntersuchen(s_tmp)
->Suchbereichsende vor Namen setzen
l_PosEnd = l_StartName_anf - 1
Loop While l_PosEnd > 0
Selection.Collapse
If f_NJ_cnt = 0 Then
MsgBox (Nichts gefunden.)
Else
Call NamenSortieren(f_NJ(), f_NJ_cnt)
Call NahmeJahrInNeuemDocAusgeben(f_NJ(), f_NJ_cnt)
End If
Aufraeumen:
Set doc = Nothing
End Sub
'**********************************************************
Private Function NahmeJahrInNeuemDocAusgeben( _
f_NJ() As myNameJahreszahl_structure, f_NJ_cnt As Long)
Dim newdoc As Document, x As Long
Set newdoc = Documents.Add
For x = 1 To f_NJ_cnt
If f_NJ(x).s_Jahreszahl = Then
Selection.InsertAfter f_NJ(x).s_Name & vbCrLf
Else
Selection.InsertAfter f_NJ(x).s_Name & ( & _
f_NJ(x).s_Jahreszahl & ) & vbLf
End If
Next
Set newdoc = Nothing
End Function
'**********************************************************
Private Function NamenSortieren( _
f_NJ() As myNameJahreszahl_structure, f_NJ_cnt As Long)
->sortiert das Feld nach Namen
Dim s_tmp As myNameJahreszahl_structure, x As Long, y As Long
For x = 1 To f_NJ_cnt - 1
For y = x + 1 To f_NJ_cnt
If String1GroesserString2(f_NJ(x).s_Name, f_NJ(y).s_Name) Then
s_tmp = f_NJ(x)
f_NJ(x) = f_NJ(y)
f_NJ(y) = s_tmp
End If
Next
Next
End Function
'**********************************************************
Private Function String1GroesserString2(s1 As String, s2 As String) As Boolean
->Groß/Kleinschreibung wird nicht berücksichtigt
If s1 = Then String1GroesserString2 = False
If s2 = Then String1GroesserString2 = True
If Len(s1) > Len(s2) Then
If LCase(Left(s1, Len(s2))) > LCase(Left(s2, Len(s2))) Then
String1GroesserString2 = True
Else
String1GroesserString2 = False
End If
Else
If LCase(Left(s1, Len(s1))) > LCase(Left(s2, Len(s1))) Then
String1GroesserString2 = True
Else
String1GroesserString2 = False
End If
End If
End Function
'**********************************************************
Private Function NachfolgendenTextAufJahreszahlUntersuchen( _
s_tmp As String) As String
->gibt die ggf. enthaltene Jahreszahl zurück
Dim s As String, x As Long
Dim l_KlammerAuf As Long, l_AnzZahl As Long
NachfolgendenTextAufJahreszahlUntersuchen =
s_tmp = Trim(s_tmp)
If Len(s_tmp) = 0 Then Exit Function
->zeicheweise untersuchen
l_KlammerAuf = 0
l_AnzZahl = 0
For x = 1 To Len(s_tmp)
s = Mid(s_tmp, x, 1)
Select Case s
Case (
l_KlammerAuf = l_KlammerAuf + 1
If l_KlammerAuf > 1 Then Exit Function
Case 0 To 9
l_AnzZahl = l_AnzZahl + 1
If l_AnzZahl = 4 Then
NachfolgendenTextAufJahreszahlUntersuchen = _
Mid(s_tmp, x - l_AnzZahl + 1, l_AnzZahl)
Exit Function
End If
Case
If l_AnzZahl > 0 Then Exit Function
Case Else
Exit Function
End Select
Next x
End Function
