AW: Spalten spiegeln
17.02.2021 09:27:03
Nepumuk
Hallo Christian
teste mal:
Option Explicit
Public Sub Transpose_Test()
Dim vntArt 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
vntArt = 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(vntArt) = vbBoolean And vntArt = False Then Exit Sub
If Fix(vntArt) = vntArt Then If vntArt >= 0 And vntArt <= 3 Then Exit Do
MsgBox Prompt:="Nur die Zahlen 0 / 1 / 2 zulässig.", _
Buttons:=vbExclamation, Title:="Hinweis"
Loop
Call Transpose_special(rngInputrange, rngOutputrange, Clng(vntArt))
Err_Exit:
End Sub
Private Sub Transpose_special(ByVal rngInputrange As Range, _
ByVal rngOutputrange As Range, _
ByVal lngArt As Long)
Dim avntArray() As Variant, lngRow As Long, lngColumn As Long
On Error GoTo Err_Exit
Select Case lngArt
Case 0
If rngOutputrange.Column + rngInputrange.Rows.Count - 1 <= Columns.Count Then
avntArray = Application.Transpose(rngInputrange.Formula)
rngInputrange.Clear
Range(rngOutputrange.Cells(1, 1), Cells(rngOutputrange.Row + _
rngInputrange.Columns.Count - 1, rngOutputrange.Column + _
rngInputrange.Rows.Count - 1)).Formula = avntArray
Else
Err.Raise Number:=vbObjectError + 1, Description:="Das passt nicht rein."
End If
Case 1
If rngOutputrange.Row + rngInputrange.Rows.Count - 1 <= Columns.Count Then
Redim avntArray(1 To rngInputrange.Rows.Count, 1 To rngInputrange.Columns.Count)
For lngColumn = 1 To rngInputrange.Columns.Count
For lngRow = 1 To rngInputrange.Rows.Count
avntArray(lngRow, lngColumn) = rngInputrange.Cells( _
rngInputrange.Rows.Count - lngRow + 1, _
rngInputrange.Columns.Count - lngColumn + 1).Formula
Next
Next
rngInputrange.Clear
Range(rngOutputrange.Cells(1, 1), Cells(rngOutputrange.Row + _
rngInputrange.Rows.Count - 1, rngOutputrange.Column + _
rngInputrange.Columns.Count - 1)).Formula = avntArray
Else
Err.Raise Number:=vbObjectError + 2, Description:="Das passt nicht rein."
End If
Case 2
If rngOutputrange.Column + rngInputrange.Rows.Count - 1 <= Columns.Count Then
Redim avntArray(1 To rngInputrange.Columns.Count, 1 To rngInputrange.Rows.Count)
For lngColumn = 1 To rngInputrange.Columns.Count
For lngRow = 1 To rngInputrange.Rows.Count
avntArray(lngColumn, lngRow) = _
rngInputrange.Cells(rngInputrange.Rows.Count - _
lngRow + 1, rngInputrange.Columns.Count - lngColumn + 1).Formula
Next
Next
rngInputrange.Clear
Range(rngOutputrange.Cells(1, 1), Cells(rngOutputrange.Row + _
rngInputrange.Columns.Count - 1, rngOutputrange.Column + _
rngInputrange.Rows.Count - 1)) = avntArray
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, vbCritical, "Fehler"
End Sub
Gruß
Nepumuk