Daten sortieren per VBA Skript

tarzipan7 · 2024-06-06T15:36:09+00:00

Hallo zusammen, ich muss Einträge einer Tabelle sortieren: die Basis dazu sieht in etwa so aus; a1 0 a1 100 a1 200 b1 300 c1 400 c1 500 d1 600 d1 700 e1 800 das Ziel ist: a1 0 100 200 b1 300 c1 400 500 d1 600 700 e1 800 Dies sollte per Button durch einen Skript erfolgen. Ich habe schon rumprobiert und bekomme es nicht hin, kann mir da jemand helfen? Danke und Gruß

Hi
brauchst du nur die Werte oder müssen auch die Formate übernommen werden?

im Prinzip brauchst du eigentlich nur zwei Formeln:

in D1: =Eindeutig(Filter(A:A;A:A>""))
in E1: =Mtrans(Filter(B:B;A:A=D1))

die Formel in D1 spillt die Werte automatisch nach unten, dh das passt sich an, wenn du neue Daten in A:B einfügst
die Formel in E1 müsstest du dann noch anpassen und aus E1 soweit nach unten kopieren wie Daten vorliegen.
Aufgrund der variablen Anzahl an Spalten hab ich noch keine Idee, wie man hier einen horizontalen und vertikalen Spill hinbekommt.

also das einfachste Makro wäre dann:

Sub TransponierenMitFormel()

With Range("D1")

    .CurrentRegion.ClearContents

    .Formula2R1C1 = "=UNIQUE(FILTER(C1,C1>""""))"

    .SpillingToRange.Offset(0, 1).Formula2R1C1 = "=TRANSPOSE(FILTER(C2,C1=RC[-1]))"

    .CurrentRegion.Formula = .CurrentRegion.Value

End With

End Sub

wenn man die Daten direkt "am Platz" umwandeln will oder wenn man nicht über Excel 365 verfügt, dann so:

Sub TransponierenKlassisch()

With Cells(1, 1).CurrentRegion

    .Sort Key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlGuess

    With .Columns(.Columns.Count + 1)

        .FormulaR1C1 = "=RC2&if(RC1=R[1]C1,""|""&R[1]C,"""")"

        .Formula = .Value

    End With

End With

Range("A:C").RemoveDuplicates 1, xlGuess

Columns(3).TextToColumns Destination:=Cells(1, 3), _

    DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _

    Tab:=False, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="|"

Columns(2).Delete

End Sub

Gruß Daniel

Hallo, ich schaue mir das bei Gelegenheit mal an (PowerQuery)

Werde natürlich auch die anderen von euch vorgeschlagenen Lösungen ausprobieren.



Sub Makro1()

'

' Makro1 Makro

    Dim ws As Worksheet

    Dim SrcCell As Range

    Dim DstCell As Range

    Dim suchBereich As Range

    Dim zielBereich As Range

    Dim suchWert As Variant

    Dim DstRange As Long

    Dim RowsCnt As Long

    Dim i As Integer

    Dim j As Integer

    Dim gefunden As Range

    Dim quelleBereich As Range

    Dim firstAddress As String

    



    

' Arbeitsblatt festlegen

    Set ws = ActiveSheet

    

' Quellbereich auswählen

    On Error Resume Next

    Set SrcCell = Application.InputBox("Bitte die Startzelle im Quellbereich eingeben:", "Startzelle eingeben", Type:=8)

    On Error GoTo 0

    SrcCell.Select

    

    ' Abbrechen, wenn keine Startzelle ausgewählt wurde

    If SrcCell Is Nothing Then Exit Sub

    

    Set DstCell = Application.InputBox("Bitte die Zielzelle im Zielbereich eingeben:", "Zielzelle eingeben", Type:=8)

    On Error GoTo 0

    DstCell.Select

    

    ' Abbrechen, wenn keine Zielzelle ausgewählt wurde

    If DstCell Is Nothing Then Exit Sub

    

    SrcCell.Cells.Select

    

    Range(Selection, Selection.End(xlDown)).Select

    Selection.Copy



    DstCell.Cells.Select

    ActiveSheet.Paste

    Range(Selection, Selection.End(xlDown)).Select



    Selection.RemoveDuplicates Columns:=1, Header:=xlNo



    DstCell.Cells.Select

    Range(Selection, Selection.End(xlDown)).Select

    Set zielBereich = Selection

    RowsCnt = Selection.Rows.Count 'used for later loop

    Selection.End(xlDown).Select



    ActiveCell.Offset(1, 0).Range("A1").Select

    Application.CutCopyMode = False

    

    

    '----------------------------------------------------------------------------------

    ' Suchbereich festlegen

    Set suchBereich = ws.Range("A1:A100")

    suchBereich.Select

    

  

    For i = 1 To RowsCnt

        suchWert = zielBereich.Rows(i)

    

   ' Suchwert finden

        Set gefunden = suchBereich.Find(What:=suchWert, LookIn:=xlValues, LookAt:=xlWhole)

        gefunden.Select

        

        If Not gefunden Is Nothing Then

            firstAddress = gefunden.Address

            

            Do

                ' Bereich rechts neben dem gefundenen Suchwert festlegen

                Set quelleBereich = gefunden.Offset(0, 1)

                'Set quelleBereich = ws.Range(gefunden.Offset(0, 1), ws.Cells(gefunden.Row, ws.Columns.Count).End(xlToLeft))

                quelleBereich.Select

                ' Zielbereich festlegen (rechte letzte Zelle im Zielbereich)

                Set letzteZielZelle = ws.Cells(zielBereich.Row, ws.Columns.Count).End(xlToLeft)

                If IsEmpty(letzteZielZelle.Value) Then

                    Set zielZelle = letzteZielZelle

                Else

                    Set zielZelle = letzteZielZelle.Offset(0, 1)

                    zielZelle.Select

                End If

                

                ' Kopieren der Werte

                quelleBereich.Copy Destination:=zielZelle



            ' Nächstes Vorkommen des Suchwerts finden

            Set gefunden = suchBereich.FindNext(gefunden)

            gefunden.Select

            Loop While Not gefunden Is Nothing And gefunden.Address > firstAddress

        End If

    Next i

End Sub

Ich habe mal ein wenig rumprobiert, aber in dieser Zeile funktioniert das nicht:

Set letzteZielZelle = ws.Cells(zielBereich.Row, ws.Columns.Count).End(xlToLeft)

Diese Selektion sollte ja bei einer neuen Anwahl von a1 zum nächsten zb b1 auch um eine Zeile runtergehen und die Werte rechts davon reinkopieren.
Ich weiss, dass einige "selects" nicht nötig sind, habe diese nur reingemacht, so das ich beim Debuggen sehen kann, ob die richtige Zelle gewählt wird :-)

Viele Grüsse

Forumthread: Daten sortieren per VBA Skript

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Daten sortieren per VBA Skript

Forumthread: Daten sortieren per VBA Skript

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread