Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Transportieren

Betrifft: Transportieren von: Tom
Geschrieben am: 21.10.2020 12:39:47

Hallo zusammen,

gibt es hierfür ein variables Makro?

Gewisse Datenmenge in Spalte A markieren / Irgendeine Zelle B mit Cursor markieren / Transportieren

Danke
TOM

Betrifft: AW: Transportieren
von: Daniel
Geschrieben am: 21.10.2020 12:46:38

Hi

mit folgendem Ablauf:

Werte in Spalte A durch runterziehen der Markierung markieren.
Zelle in Spalte B mit gedrückter STRG-Taste der Markierung hinzufügen.

dann dieses Code ausführen:
Selection.Areas(1).Copy
Selection.Areas(2).PasteSpecial xlpasteall
Areas sind bei einer Selection/Zellbereich, der mit STRG aus mehreren Blöcken zusammengestellt wurde, die einzelnen rechteckigen lückenlosen blöcke.

Gruß Daniel

Betrifft: AW: Transponieren
von: Nepumuk
Geschrieben am: 21.10.2020 12:54:45

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

Betrifft: AW: Transponieren
von: Tom
Geschrieben am: 21.10.2020 13:07:25

Perfekt Vielen Dank!!!