Autorenkorrektur: Schnelles Korrigieren von nummerierten Wörtern mit Wörtertausch in Word

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