Autor: Max Kaffl (Nepumuk)  --- Aus Excel VBA - Gruppe: Verschiedenes

Mtrans /Transponieren - Spezial

Autor: Max Kaffl (Nepumuk) - Erstellt: --      - Letzte Revision: --
Transponieren spezial

Mit folgender kleinen Routine lässt sich nicht nur die Tabellenfunktion MTRANS ausführen sondern auch spiegeln sowie spiegeln und transponieren. Es funktioniert nicht nur in einen anderen Bereich, sondern auch in den Ursprungsbereich. Formate gehen dabei aber verloren. Der Versuch, dass ganze in einer geschützten Tabelle auszuführen, erzeugt eine Fehlermeldung.

Beispiel:

ursprüngliche Ansicht
 ABCDEFGHIJ
112345678910
2abcdefghij
3einszweidreivierfünfsechssiebenachtneunzehn
 

einfaches transponieren
 ABC
11aeins
22bzwei
33cdrei
44dvier
55efünf
66fsechs
77gsieben
88hacht
99ineun
1010jzehn
 

spiegeln
 ABCDEFGHIJ
1zehnneunachtsiebensechsfünfvierdreizweieins
2jihgfedcba
310987654321
 

spiegeln und transponieren
 ABC
1zehnj10
2neuni9
3achth8
4siebeng7
5sechsf6
6fünfe5
7vierd4
8dreic3
9zweib2
10einsa1
 


Option Explicit
 
Public Sub Transpose_Test()
 Dim varArt As Variant
 Dim rngInputrange As Range, rngOutputrange As Range
 On Error Resume Next
 Set rngInputrange = Application.InputBox( _
 Prompt:="Eingabebereich mit der Maus markieren.", _
 Title:="Auswahl", Type:=8)
  If Err.Number <> 0 Then Exit Sub
 Set rngOutputrange = Application.InputBox( _
 Prompt:="Oberste linke Zelle des Ausgabebereiches mit der Maus markieren.", _
 Title:="Auswahl", Type:=8)
  If Err.Number <> 0 Then Exit Sub
 On Error GoTo Err_Exit
 Do
  varArt = Application.InputBox(Prompt:="Art auswählen" & vbLf & vbLf & _
  "0 = Normales transponieren" & vbLf & _
  "1 = Zeilen und Spalten spiegeln" & vbLf & _
  "2 = Zeilen und Spalten spiegeln und transponieren", _
  Title:="Auswahl", Default:=0, Type:=1)
   If VarType(varArt) = vbBoolean And varArt = False Then Exit Sub
   If Fix(varArt) = varArt Then If varArt >= 0 And varArt <= 3 Then Exit Do
  MsgBox Prompt:="Nur die Zahlen 0 / 1 / 2 zulässig.", _
  Buttons:=vbExclamation, Title:="Hinweis"
 Loop
 Call Transpose_special(rngInputrange, rngOutputrange, CByte(varArt))
 Err_Exit:
End Sub
 
Private Sub Transpose_special(ByVal rngInputrange As Range, _
 ByVal rngOutputrange As Range, _
 ByVal bytArt As Byte)
 Dim varArray() As Variant, lngRow As Long, intColumn As Integer
 On Error GoTo Err_Exit
 Select Case bytArt
  Case 0
   If rngOutputrange.Column + rngInputrange.Rows.Count - 1 <= 256 Then
    varArray = Application.WorksheetFunction.Transpose(rngInputrange)
    rngInputrange.Clear
    Range(rngOutputrange.Cells(1, 1), Cells(rngOutputrange.Row + _
    rngInputrange.Columns.Count - 1, rngOutputrange.Column + _
    rngInputrange.Rows.Count - 1)) = varArray
   Else
    Err.Raise Number:=vbObjectError + 1, Description:="Das passt nicht rein."
   End If
  Case 1
   If rngOutputrange.Row + rngInputrange.Rows.Count - 1 <= 256 Then
    ReDim varArray(1 To rngInputrange.Rows.Count, _
    1 To rngInputrange.Columns.Count)
    For intColumn = 1 To rngInputrange.Columns.Count
     For lngRow = 1 To rngInputrange.Rows.Count
      varArray(lngRow, intColumn) = rngInputrange.Cells( _
      rngInputrange.Rows.Count - lngRow + 1, _
      rngInputrange.Columns.Count - intColumn + 1)
     Next
    Next
    rngInputrange.Clear
    Range(rngOutputrange.Cells(1, 1), Cells(rngOutputrange.Row + _
    rngInputrange.Rows.Count - 1, rngOutputrange.Column + _
    rngInputrange.Columns.Count - 1)) = varArray
   Else
    Err.Raise Number:=vbObjectError + 2, Description:="Das passt nicht rein."
   End If
  Case 2
   If rngOutputrange.Column + rngInputrange.Rows.Count - 1 <= 256 Then
    ReDim varArray(1 To rngInputrange.Columns.Count, _
    1 To rngInputrange.Rows.Count)
    For intColumn = 1 To rngInputrange.Columns.Count
     For lngRow = 1 To rngInputrange.Rows.Count
      varArray(intColumn, lngRow) = _
      rngInputrange.Cells(rngInputrange.Rows.Count - _
      lngRow + 1, rngInputrange.Columns.Count - intColumn + 1)
     Next
    Next
    rngInputrange.Clear
    Range(rngOutputrange.Cells(1, 1), Cells(rngOutputrange.Row + _
    rngInputrange.Columns.Count - 1, rngOutputrange.Column + _
    rngInputrange.Rows.Count - 1)) = varArray
   Else
    Err.Raise Number:=vbObjectError + 3, Description:="Das passt nicht rein."
   End If
 End Select
 Exit Sub
 Err_Exit:
 MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
 Err.Description, 16, "Fehler"
End Sub


Weitere Artikel der Gruppe: Verschiedenes Aus Excel VBA
Nach oben
ToDo
Google Werbung