Text Konsolidieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Gesammelt_transponieren() Dim Z As Range 'Zelle Dim D As Object Dim K, Elt 'Key und Element Const TS = "E4" 'Türstopper für den End(xlToLeft). Zelle muss leer sein Set D = CreateObject("Scripting.Dictionary") With Worksheets("Tabelle1") 'Sammeln For Each Z In .Range(.Range("A5"), .Range("A9999").End(xlUp)).Cells If D.exists(Z.Value) Then D(Z.Value) = D(Z.Value) & ";" & Z.Offset(0, 1).Value Else D(Z.Value) = Z.Offset(0, 1).Value End If Next 'Ausgeben .Range(TS) = "x" 'Türstopper setzen For Each K In D.Keys Set Z = .Range(TS).Offset(0, 1000).End(xlToLeft).Offset(0, 1) Z = K For Each Elt In Split(D(K), ";") Set Z = Z.Offset(1, 0) Z = Elt Next Next .Range(TS).ClearContents 'Türstopper wieder löschen End With End Sub

Hallo Abdullah,
um das gleiche Ergebnis mit Power Query (PQ) zu erreichen:
(Wobei Du mit Excel 2007 PQ nachinstallieren müsste. Aber es gibt ja jetzt Excel 2021! Fährst Du eine 14 Jahre alte Auto?)
_ mache aus dein Tabelle eine aktive Tabelle: eine Zelle davon auswählen und Strg+t oder "Einfügen", "Tabelle". Wenn deine Liste keine Überschrift hat, wird einigen eingefügt: "Spalte1", "Spalte2", ... Nehmen wir einfach an, die erste heisst "Loeten", die zweite "Los".
_ im Menü "Daten", "Aus Tabelle"
jetzt bist Du im PQ Editor
_ markiere die erste Spalte "Loeten"
_ im Menü "Transformieren", "Gruppieren nach" auswählen
_ "Gruppieren nach" ist schon festgelegt, Name der neuen Spalte: "GroupIndex", Vorgang "Alle Zeilen", ok.
_ gehe auf "Start", "erweiterte Editor"
_ füge dort nach der letzten Zeiel vor dem "in": Indexed = Table.TransformColumns(#"Gruppierte Zeilen", {{"GroupIndex", each Table.AddIndexColumn(_,"GroupIndex", 1, 1)}})
_ füge eine Komma am Ende der Zeile davor
_ nach dem "in" soll noch '#"Gruppierte Zeilen" ' stehen, ersetze duch Indexed (achtung: Case sensitiv)
_ Fertig
_ in der Spaltenüberschrift von GroupIndex auf dem doppelte Pfeil drücken, Spalten "Los" und "GroupIndex" auswählen
_ Spalte "Loeten" markieren,
_ im "Transformieren" auf "Spalte pivotieren" gehen,
_ Wertespalte "Los" auswählen, "Erweiterte Funktion" auf "nicht aggregieren" stellen (wobei es sollte hier keine wirkung haben),
_ Spalte "GroupIndex" entfernen
_ Im Menü "Datei", "Schliessen und laden in"
Fertig.
Kommt eine neue Werte unter die bisherige Liste, wird sich die Aktive Tabelle automatisch erweitern. Auf das Ergebnis-Tabelle musst Du nur noch rechtsklicken und "aktualisieren" wählen.
Kommen diese Werte aus eine csv-Datei, ist es noch schöner. Aber da schaust Dir am besten ein paar Tutorial an.
Power Query ist leichter zu erfassen und anzupassen, stabiler und bei grossen Listen schneller als VBA. Davon ausgesehen mögen macnhe Firmen keine Datei "mit Makros".
VG
Yal

Hallo Yal,
... ich hatte damit vor Monaten einen Bekannten bei (s)einem sehr spez. Problem helfen wollen. Nach meiner damaligen abschließenden Meinung sah ich für mich keinen Weg, wie es einer idealen Lösung zugeführt werden kann. Bewusst war mir nur, dass man da sicher noch optimieren kann, aber der Bekannte war erst einmal froh überhaupt einen, seiner Meinung nach ausreichenden Vorschlag, bekommen zu haben. Dieser erschien für ihn geeigneter, als womit er bisher das Problem angepackt hatte. Er hat sich dann auch nicht wieder gemeldet und dann war es für mich: "Aus dem Auge aus dem Sinn".
Also wenn es Dich noch/wieder interessieren sollte und Du in den letzten Tages des Jahres wirklich nicht besseres vorhast, dann würde mich eine bessere Lösung natürlich auch wieder interessieren.
Wünsche Dir nun aber erst einmal einen schönen 3. Advent.
Gruß Werner
.. , - ...

Sub test() With Range("A5").CurrentRegion With .Columns(.Columns.Count + 1) .FormulaR1C1 = "=RC2&IF(RC1=R[1]C1,"";""&R[1]C,"""")" .Copy .PasteSpecial xlPasteValues End With End With With Range("A5").CurrentRegion .RemoveDuplicates 1, xlNo .Columns(3).TextToColumns Destination:=.Cells(1, 3), _ DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _ Tab:=False, Semicolon:=True, Comma:=False, Space:=False, Other:=False .Columns(2).Delete shift:=xlToLeft End With Range("A5").CurrentRegion.Copy Sheets("Tabelle2").Range("A1").PasteSpecial xlPasteAll, Transpose:=True Application.CutCopyMode = False End Sub

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread