Schnelles Korrigieren mit Wörtertausch

Besonders Teilnehmer an PC-Wettbewerben im Schnellschreiben können in der Disziplin Autorenkorrektur diese Routine einsetzen. Falls der Autor zur Korrektur der Reihenfolge die Wörter eines Satzes oder einer Wortgruppe nummeriert, kann dieses Makro zur Anwendung gelangen. Zunächst werden die zu tauschenden Wörter markiert. Dann wird das Makro ausgelöst, am sinnvollsten mittels eines definierten → Shortcuts. Es erscheint eine Eingabeaufforderung, die anzeigt, wie viele Wörter markiert sind, und die neue Reihenfolge erfragt. Dabei sind die Satzzeichen jeweils als Wort mitzuzählen, denn deren Stellung ändert sich ja dabei gegebenenfalls auch. Die Routine läuft ab Word 2000 (Word 9).



Sub Worttausch()   

' läuft ab VBA 6, also ab Word 2000 (Word 9), VBA 5 hat keine Split-Funktion
' vertauscht einzelne Wörter, dient zur schnelleren Korrektur,
' wenn die Wortstellung mittels Nummerierung geändert wurde ' © Schreibbüro Nora Richter
Dim myRange As Range
Dim Eingabe As String
Dim Reihf() As String
Dim Anzahl As Long
Dim Ausgabe As String
Dim i As Long
Const evTitel As String = "Wort-Tausch-Makro von Schreibbüro Richter aka Lisa"

If Len(Selection.Range) = 0 Then
MsgBox Prompt:="Es ist kein Text markiert.", Buttons:=vbInformation, Title:=evTitel
Exit Sub
End If
' Falls nichts markiert ist, abbrechen

If Right(Selection.Range, 1) = Chr(13) Then
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=True
End If
' Zeilenendzeichen (Enterschaltung) "aussperren"

Set myRange = Selection.Range

With myRange
Anzahl = .Words.Count ' Feststellen, wie viele Wörter markiert sind
Eingabe = InputBox(Prompt:="Bitte die Reihenfolge der " & Anzahl & " Wörter eingeben," _
& Chr(13) & "getrennt durch Kommata!" & Chr(13) & _
"Satzzeichen mitzählen!" & Chr(13) & Chr(13) & Chr(13) & _
Anzahl & " Zahlen eingeben!", Title:=evTitel)
' Die Reihenfolge erfragen

If Not EingabeOK(Eingabe, Anzahl, evTitel) Then
Selection.Collapse wdCollapseEnd
Set myRange = Nothing
Exit Sub
End If
' Falls der Nutzer eine ungültige Reihenfolge eingegeben hat, abbrechen

ReDim Reihf(1 To Anzahl)
Reihf = Split(Eingabe, Chr(44), Anzahl, vbBinaryCompare)
' Die Wörter werden "vereinzelt"

For i = 0 To Anzahl - 1
If i = 0 Then
Ausgabe = Trim(.Words(Reihf(i)))
ElseIf i > 0 Then
Select Case Right(Ausgabe, 1)
Case Is = "(", "[", "", "", "/", "-"
Ausgabe = Ausgabe & Trim(.Words(Reihf(i)))
Case Else
Select Case Left(.Words(Reihf(i)), 1)
Case Is = ",", ";", ".", "!", "?", ":", ")", "", "", "]", "/", "-"
Ausgabe = Ausgabe & Trim(.Words(Reihf(i)))
Case Else
Ausgabe = Ausgabe & " " & Trim(.Words(Reihf(i)))
End Select
End Select
End If
If i = Anzahl - 1 Then
Ausgabe = Ausgabe & " "
End If
Next i
.Delete
.Text = Ausgabe
End With

Erase Reihf
Set myRange = Nothing

With Selection
.MoveRight Unit:=wdWord, Count:=Anzahl
.MoveLeft Unit:=wdCharacter, Count:=2, Extend:=True
If .Range = " " Then ' doppelte Leertasten vermeiden
.Delete
.TypeText " "
Else
.Collapse wdCollapseEnd
End If
End With

End Sub

Function EingabeOK(Eingabe As String, ByVal Anzahl As Long, ByVal evTitel As String) As Boolean
' validiert die Eingabe der Wörter hinsichtlich der Anzahl
Dim ZahlKomma As Long
Dim i As Long
Dim KommaOK As Boolean
Dim Testarray() As String

EingabeOK = False
ZahlKomma = 0
Eingabe = Trim(Eingabe)

If Eingabe = "" Then
EingabeOK = False
Exit Function
End If

If Right(Eingabe, 1) = "," Then
Eingabe = Mid(Eingabe, 1, Len(Eingabe) - 1)
Eingabe = Trim(Eingabe)
End If

For i = 1 To Len(Eingabe)
If Mid(Eingabe, i, 1) = "," Then
ZahlKomma = ZahlKomma + 1
End If
Next i

Select Case ZahlKomma
Case Is = 0
KommaOK = False
MeldungFehler Anzahl, evTitel, Meldungsart:="Falsch"
Exit Function
Case Is >= Anzahl
KommaOK = False
MeldungFehler Anzahl, evTitel, Meldungsart:="zu viel"
Exit Function
Case Is = Anzahl - 1
KommaOK = True
Case Else
KommaOK = False
MeldungFehler Anzahl, evTitel, Meldungsart:="zu wenig"
Exit Function
End Select

If Not KommaOK Then
MeldungFehler Anzahl, evTitel, Meldungsart:="Falsch"
Exit Function
End If

ReDim Testarray(1 To Anzahl)
Testarray() = Split(Eingabe, Chr(44), -1, vbBinaryCompare)

For i = 0 To Anzahl - 1
If Not IsNumeric(Testarray(i)) Then
MeldungFehler Anzahl, evTitel, Meldungsart:="Zahl"
Exit For
Exit Function
ElseIf CLng(Testarray(i)) > Anzahl Then
MeldungFehler Anzahl, evTitel, Meldungsart:="zu hoch"
Exit For
Exit Function
Else
EingabeOK = True
End If
Next i

Erase Testarray

End Function

Sub MeldungFehler(ByVal Anzahl As Long, ByVal evTitel As String, ByVal Meldungsart As String)
' legt nur die Fehlermeldung fest, falls die Eingabe nicht OK ist
Dim Reakt As Byte
Dim Meldungstext As String

Select Case Meldungsart
Case "Falsch"
Meldungstext = "Die Zahlen für die Reihenfolge der " & Anzahl & _
" Wörter " & Chr(13) & "müssen durch Kommata getrennt werden!"
Case "zu viel"
Meldungstext = "Sie haben zu viele Zahlen eingegeben." & Chr(13) & _
"Es sind nur " & Anzahl & " Worte!"
Case "zu wenig"
Meldungstext = "Sie haben zu wenige Zahlen eingegeben." & Chr(13) & _
"Es müssen " & Anzahl & " Worte sein!"
Case "Zahl"
Meldungstext = "Sie müssen Zahlen für die Reihenfolge der " & Anzahl & _
" Wörter eingeben!"
Case "zu hoch"
Meldungstext = "Sie haben eine zu hohe Zahl eingegeben." & Chr(13) & _
"Die höchste Zahl ist: " & Anzahl & "!"
End Select
Meldungstext = Meldungstext & Chr(13) & Chr(13) & "Möchten Sie es nochmals versuchen?"

Reakt = MsgBox(Prompt:=Meldungstext, Title:=evTitel, Buttons:=vbExclamation + vbYesNo)
Select Case Reakt
Case Is = vbNo, vbCancel
Exit Sub
Case Is = vbYes
Worttausch
End Select
End Sub
Schreibbüro Richter, Georg-Schumann-Str. 8, 04105 Leipzig, Tel.: (03 41) 59 008 95