title image


Smiley Excel Liste um 90 Grad drehen
Hallo zusammen,



ich benötige ein Makro, um eine Excel Tabelle zu drehen. Zur Veranschaulichung:



1234

a

b

c

d



ändern in



abcd

1

2

3

4



im Word Forum habe ich bereits folgendes Makro gefunden, was mir aber leider einen Kompilierungsfehler ausgibt.

Vielen Dank im voraus.



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













geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: