title image


Smiley Re: Tabelle um 90 Grad drehen


Willst Du die Seite drehen?

DinA4 Querformat?



Oder willst Du die zeilen und Spalten tauschen?



a b c d

1 2 3 4











a 1

b 2

c 3

d 4



http://mypage.bluewin.ch/reprobst/WordFAQ/Button.htm









Option Explicit





Sub TabelleDrehen()



    Dim tblMyTableSource                As Table   ' Quell-Tabelle

    Dim tblMyTableDestiny               As Table   ' Ziel-Tabelle

    Dim cellMyCell                      As Cell    ' einzelne Zelle

    Dim intSpaltenAnz                   As Integer ' gesamte Anzahl S

    Dim intZeilenAnz                    As Integer ' gesamte Anzahl Z

    Dim intAltePos                      As Integer ' Cursor Position

    Dim rngSourceRange                  As Range   ' Quell-Range in der Tabelle



    

    ' ggf Abbruch

    If Application.Documents.Count <= 0 Then

        Exit Sub

    End If

    

    ' ggf. Markierung reduzieren

    Selection.Collapse wdCollapseStart

    

    ' ggf Abbruch

    If Selection.Information(wdWithInTable) = False Then

        MsgBox "Der Cursor befindet sich leider nicht in einer Tabelle.", _

               vbInformation, _

               "Tabelle drehen"

        Exit Sub

    End If

    

    ' Cursor Position sichern

    intAltePos = Selection.Start

    

    ' Der Variablen "tblMyTableSource" einen Objektverweis auf die alte Tabelle

    ' zuweisen

    Set tblMyTableSource = Selection.Tables(1)

    

    ' Tabelle vermessen

    intSpaltenAnz = tblMyTableSource.Columns.Count

    intZeilenAnz = tblMyTableSource.Rows.Count

    

    ' Ans Ende der Tabelle gehen

    Selection.EndOf unit:=wdTable, Extend:=wdMove

    Selection.Move unit:=wdCharacter, Count:=2

    

    Documents.Add

    

    ' Leerzeilen

    Selection.InsertParagraphAfter

    Selection.InsertParagraphAfter

    Selection.InsertParagraphAfter

    Selection.Collapse wdCollapseEnd

    

    ' Neue Tabelle einfügen mit Objektverweis an die Variable "tblMyTableDestiny"

    Set tblMyTableDestiny = ActiveDocument.Tables.Add(Selection.Range, intSpaltenAnz, intZeilenAnz)



    ' Schleife: Alle Zellen durchgehen

    For Each cellMyCell In tblMyTableSource.Range.Cells

        

        ' nun Zeile und Spalte vertauscht kopieren

        With tblMyTableDestiny.Cell(cellMyCell.ColumnIndex, cellMyCell.RowIndex).Range

            ' Quell-Range in der Tabelle setzen

            Set rngSourceRange = tblMyTableSource.Cell(cellMyCell.RowIndex, cellMyCell.ColumnIndex).Range

            ' Text kopieren

            .Text = ZellenInhalt(rngSourceRange.Cells(1))   ' rngSourceRange.Text

            ' Format kopieren

            .Font = rngSourceRange.Font

            ' Schattierung kopieren

            .Shading.BackgroundPatternColor = rngSourceRange.Shading.BackgroundPatternColor

        End With

        

    Next cellMyCell ' Schleifenende

    

    ' Cursor an alte Position zurück

    Selection.SetRange Start:=intAltePos, End:=intAltePos

    

End Sub



Function ZellenInhalt(lokalMeineZelle As Cell) As String



    ' usage: ZellenInhalt(aRow.cells(1))

    ' liefert: Zellen-Inhalt ohne Absatzmarke etc. am Ende (deswegen -2)



    With lokalMeineZelle.Range

        ZellenInhalt = Trim(Left(.Text, Len(.Text) - 2))

    End With

    

End Function







Code eingefügt mit Syntaxhighlighter 2.4









geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: