AW: Transponieren
21.10.2020 12:54:45
Nepumuk
Hallo Tom,
teste mal:
Option Explicit
Public Sub Transponieren()
Dim objRangeSource As Range, objRangeTarget As Range
Dim objRangeCollection As Collection
Set objRangeCollection = New Collection
Do
objRangeCollection.Add Application.InputBox(Prompt:= _
"Bitte die Quelle markieren", Title:="Auswahl", Type:=8)
If TypeOf objRangeCollection(objRangeCollection.Count) Is Range Then
Set objRangeSource = objRangeCollection(objRangeCollection.Count)
Exit Do
ElseIf IsEmpty(objRangeCollection(objRangeCollection.Count)) Then
MsgBox "Objektzuweisung fehlgeschlagen. Bitte nochmal versuchen", _
vbCritical, "Fehlermeldung"
ElseIf Not objRangeCollection(objRangeCollection.Count) Then
Exit Sub 'cancelbutton pressed
Else
MsgBox "Fehler " & CStr(vbObjectError) & vbLf & vbLf & _
"Unbekannter Objektfehler beim zuweisen eines Bereiches.", _
vbCritical, "Fehlermeldung"
Exit Sub
End If
Loop
Set objRangeCollection = New Collection
Do
objRangeCollection.Add Application.InputBox(Prompt:= _
"Bitte die Zielzelle markieren", Title:="Auswahl", Type:=8)
If TypeOf objRangeCollection(objRangeCollection.Count) Is Range Then
Set objRangeTarget = objRangeCollection(objRangeCollection.Count)
Exit Do
ElseIf IsEmpty(objRangeCollection(objRangeCollection.Count)) Then
MsgBox "Objektzuweisung fehlgeschlagen. Bitte nochmal versuchen", _
vbCritical, "Fehlermeldung"
ElseIf Not objRangeCollection(objRangeCollection.Count) Then
Exit Sub 'cancelbutton pressed
Else
MsgBox "Fehler " & CStr(vbObjectError) & vbLf & vbLf & _
"Unbekannter Objektfehler beim zuweisen eines Bereiches.", _
vbCritical, "Fehlermeldung"
Exit Sub
End If
Loop
Call objRangeSource.Copy
Call objRangeTarget.Cells(1, 1).PasteSpecial( _
Paste:=xlPasteValuesAndNumberFormats, Transpose:=True)
objRangeTarget.Cells(1, 1).Select
Application.CutCopyMode = False
End Sub
Gruß
Nepumuk