EDV Abmayr: Macros for Microsoft Word

English
Deutsch / German
This page contains some commonly useful macros for Microsoft Word. Diese Seite enthält einige allgemein nützliche Makros für Microsoft Word.
See Excel Macros for some common information about macros, copyright, etc. Die Seite Excel Macros enthält einige allgemeine Informationen über Makros, Copyright, etc.





List of macros with short description

Name of Macro Description
AutoOpen This macro name is predefined by Word. It is automatically executed after opening any file. The following lines cause Word to jump to the last location in the file before it had been closed. The same does manually pressing SHIFT+F5. (If Word does not know this location, it may, unfortunately, switch to another open Word file.)
     Sub AutoOpen()
         Application.GoBack
     End Sub
    
vertausche_zeilen_mit_spalten

ENGLISH: If you want to transpose the lines of a Word table into columns (and vice versa), you might expect Word to offer such a function. But this is not true. So this macro may help you to do this. Just locate the cursor at any location within the table and call this macro.
The program code of the macro is listed below.

DEUTSCH: Wenn Sie die Zeilen einer Word-Tabelle in Spalten umwandeln möchten (oder umgekehrt), würden Sie vielleicht erwarten, daß Word Ihnen diese Funktion bietet. Leider ist dies nicht der Fall. Dieses Makro führt diese Aufgabe für Sie aus, wenn Sie die Eingabemarke (Cursor) an eine beliebige Stelle in der Tabelle positionieren und dann dieses Makro aufrufen.
Den Programmcode des Makros finden Sie unten.


Sub vertausche_zeilen_mit_spalten()
'
' vertausche_zeilen_mit_spalten Makro
' Nimmt die Tabelle, in der momentan der Cursor steht (nicht mehrere Tabellen
' gleichzeitig markieren!) und vertauscht den Inhalt der Zeilen mit dem der Spalten
'

'
    Dim rows As Integer
    Dim cols As Integer
    Dim r As Integer
    Dim c As Integer
    Dim t As Table
    Dim val_1 As String
    Dim val_2 As String

    Dim ll As Integer        ' nur zum Testen
    Dim i As Integer         ' nur zum Testen
    Dim ass As Integer       ' nur zum Testen

    'Im Internet fand ich:
    '"In der Regel ist die Tabelle, in der der Cursor steht,
    '... .Tables(1). Aber da Word bekanntlich eine Zicke ist,
    'würde ich aus der aktiven Tabelle einen Range bilden."
    '(Bem. BA: Dies ist unbedingt nötig, sonst klappt es nicht!)

    Dim tRange As Range
    Set tRange = Selection.Tables(1).Range
    Set t = tRange.Tables(1)    ' This is the table in the selection

    rows = t.rows.Count      ' stores the initial value. Do not change!
    cols = t.Columns.Count   ' stores the initial value. Do not change!

    ' Wenn man das Screen-Updating während der Operationen an der Tabelle
    ' abschaltet, geht es viel schneller, weil sonst bei jedem Schritt die
    ' Tabellenmaße neu berechnet werden! Wenn man lieber zuschaut, wie das
    ' alles gemacht wird, kann man die naechste Zeile einfach auskommentieren.
    Application.ScreenUpdating = False
    ' SO DACHTE ich, die Wirklichkeit scheint aber anders zu sein (als ich von
    ' Excel her gewohnt bin): Die Tabelle wird anscheined trotzdem neu berechnet.
    ' Man sieht zwar die Tabelle nicht sich verändern, aber der Pagescroller
    ' zittert, was zeigt, daß sich die Tabellenhöhe immer wieder verändert.
    ' Deshalb fixiere ich hier noch die Tabellenformate.
    t.AutoFitBehavior (wdAutoFitFixed)
    ' Aber auch das hilft nicht allzuviel.

    ' STEP 1) Zuerst muessen wir die Tabelle quadratisch machen
    While t.rows.Count < t.Columns.Count
        t.rows.Add     ' Without parameter: add row at the end
    Wend
    While t.rows.Count > t.Columns.Count
        t.Columns.Add
    Wend

    ' STEP 2) Schleife über die Zeilen, wobei nur die Haelfte links von der Diagonalen
    ' durchlaufen wird, weil die andere Haelfte beim Vertauschen zweier
    ' Zellinhalte automatisch mitbehandelt wird.
    For r = 2 To t.rows.Count
        For c = 1 To r - 1
            ' Leider ist es mir nicht gelungen, den Zellinhalt direkt zu aendern,
            ' Der Umweg ueber die Selection ist zeitaufwendig!
            t.Cell(r, c).Select
            val_1 = Selection.text
            t.Cell(c, r).Select
            val_2 = Selection.text
                            ll = Len(val_2)
                            For i = 1 To ll
                                ass = Asc(Mid(val_2, i, 1))
                            Next i
            t.Cell(r, c).Select
            Selection.text = remove_unneeded_chars(val_2) ' see comment in function
            t.Cell(c, r).Select
            Selection.text = remove_unneeded_chars(val_1)
        Next c
    Next r

    ' STEP 3) Zum Schluss werden noch die überzähligen Zeilen oder Spalten entfernt,
    ' die ja leer sind, wenn alles funktioniert hat. Beachte: Wenn Zeilen
    ' hinzugefuegt wurden, muessen jetzt Spalten entfernt werden!
    While t.rows.Count > cols
        t.rows.Item(t.rows.Count).Delete
    Wend
    While t.Columns.Count > rows
        t.Columns.Item(t.Columns.Count).Delete
    Wend

    ' Je nach Wunsch kann man hier die Tabellenformate automatisch berechnen
    ' lassen oder nicht, indem man diese Zeile auskommentiert.
    t.AutoFitBehavior (wdAutoFitContent)

    ' Nun zeigen wir wieder das richtige Bild
    Application.ScreenUpdating = True

End Sub

Function remove_unneeded_chars(ByVal text As String) As String
    ' Beim Vertauschen der Zellinhalte wurde jedesmal ein CHR(13) angefügt (vor dem
    ' Zellen-Ende-Marker CHR(7). Warum habe ich nicht herausgefunden. Abhilfe
    ' schafft diese Funktion, indem sie diese Zeichen entfernt, wenn dahinter nichts
    ' anderes mehr folgt. (So werden natürlich auch beabsichtigte CHR(13) entfernt.
    ' Wer das nicht will, kann ganz leicht diese Funktion so abändern, daß nur
    ' der eingegebene String zurückgegeben wird.)
    Dim pos As Integer
    pos = 0
    If Asc(Mid(text, Len(text), 1) = 7) Then   ' This is the end marker of a table element

        For pos = Len(text) - 1 To 1 Step -1
            If Asc(Mid(text, pos, 1)) <> 13 Then
                Exit For
            End If
        Next pos

        ' Mid(text, pos + 1, Len(text) - pos - 1) = ""

        remove_unneeded_chars = Left(text, pos) & Chr(7)
    End If
End Function


Responsible: Bernhard Abmayr of EDV Abmayr. Last change: June, 12th, 2012