Live-Forum - Die aktuellen Beiträge
Datum
Titel
17.05.2024 11:03:10
Ganze Zahl in Ganz-Zahl Kombinationen aufteilen (ohne Rest)
17.05.2024 10:40:53
Tabellen (formatiert) über VBA auswählen
17.05.2024 10:13:05
Excel Tabelle - Ort/Stadt nur einmal pro Kunde zählen?
17.05.2024 09:40:47
Warum geht das Fenster aktualisieren auf
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1940to1944
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1940to1944
1940to1944
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Intelligentes Transponieren mit Zuordnung von Überschriften

Intelligentes Transponieren mit Zuordnung von Überschriften
11.08.2023 16:39:47
Marc
Hallo zusammen,

ich habe mir heute den ganzen Tag um die Ohren geschlagen und versucht aus Tabelle 1 Tabelle 2 zu machen...

https://www.herber.de/bbs/user/162290.xlsx

Um es nochmal in Worte zu fassen:

Ich habe eine Liste (immer wieder rund 500 Zeilen lang), die ich in vom Zeilenformat in Spalten ordnen muss (die Überschriften sind die Bezeichnungen in Tabelle1, Spalte A).

Immer, wenn das Wort Satzart in Spalte A kommt, muss eine neue Zeile begonnen werden (Tabelle2) und die entsprechenden Überschriften dazu gefunden bzw. die Texte aus Spalte B zugeordnet werden. Im Prinzip ein intelligentes Transponieren. Ich habe nun versucht über Unterschleifen das zu lösen, aber es funktioniert alles überhaupt nicht...

Vielleicht kann mir jemand hier einen entscheidenden Tipp geben und mir helfen.

Danke und Gruß
Marc

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Intelligentes Transponieren mit Zuordnung von Überschriften
11.08.2023 17:27:50
daniel
Hi
beispielsweise mit diesem Marko 

Sub test()

Sheets("Tabelle2").Cells.Clear

    

With Sheets("Tabelle1")

    .UsedRange.Columns(1).Copy

    .Cells(1, 4).PasteSpecial xlPasteValues

    .Columns(4).RemoveDuplicates 1, xlNo

    .Cells(1, 4).CurrentRegion.Copy



    Sheets("Tabelle2").Cells(1, 1).PasteSpecial xlPasteValues, Transpose:=True



    .Rows(1).Insert

    With .Cells(2, 1).CurrentRegion

        .Columns(3).FormulaR1C1 = "=R[-1]C+(RC1=""Satzart"")"

        .Columns(4).FormulaR1C1 = "=Text(RC[-1],""00000"")&""|""&rC1"

        .Formula = .Value

    End With

End With

With Sheets("Tabelle2")

    With .UsedRange.Offset(1, 0).Resize(WorksheetFunction.Max(Sheets("Tabelle1").Columns(3)))

        .FormulaR1C1 = "=iferror(Index('Tabelle1'!C2,match(text(Row()-1,""00000"")&""|""&R1C,'Tabelle1'!C4,0)),"""")"

        .Formula = .Value

    End With

End With



With Sheets("tabelle1")

    .Range("C:D").ClearContents

    .Rows(1).Delete

End With



End Sub


die Schritte sind aber auch von Hand einfach ausszuführen, gehe das Makro im Einzelstep durch und schau dir dabei an, was in der Tabelle passiert.
wenn die Verarbeitung zu lange dauert, weil die Datenmenge zu groß ist, könnte man das noch optimieren.

Gruß Daniel
Anzeige
Intelligentes Transponieren mit Zuordnung von Überschriften
11.08.2023 21:56:02
Marc
Daniel, unglaublich. Es funktioniert einwandfrei und ich werde mich morgen da reinfuxen. Das schaffe ich nach dem heutigen Tag nicht mehr! :)
ja PQ ist sicher eine gute Alternative ...
12.08.2023 13:25:52
neopa C
Hallo Luschi,

... ich hatte mich an einer PQ-Lösung gestern auch versucht, war aber leider daran mal wieder gescheitert :-(
Deshalb danke für Deine Lösung, nun konnte ich wenigstens verstehen, warum ich gescheitert bin.

Allerdings ein kleines Manko Deiner Lösung konnte ich feststellen: Die 4 "Status_#" Zeilen aus dem ersten Datenblock waren in der Ergebnis-Vorgabetabelle als letzte Spalten gelistet. Wie würdest Du in PQ das von mir bemängelte noch korrigieren?

Deren korrekte Realisierung hat mich bei meiner reinen 2-Formellösung auch die meiste Zeit bei der Definition gekostet. Eingestellt hab ich meine Formellösung aber bewußt nicht, weil ich davon ausgegangen bin, dass sicher viel mehr Datenblöcke als nur 2 oder 3 zu transponieren sind. Mich hat nur gereizt ob sich auch eine reine Formellösung definiert werden kann.

Gruß Werner
.. , - ...
Anzeige
ja PQ ist sicher eine gute Alternative ...
13.08.2023 07:43:53
Luschi
Hallo Werner,

hier mal Dein Änderungswunsch; eigentlich hatte ich dies auch als klitzekleinen Makel meines PQ-Lösung angesehen, dann aber einfach in den Hintergrund geschoben.
https://www.herber.de/bbs/user/162306.xlsx

Gruß von Luschi
aus klein-Paris
Danke, so ist es jetzt ok owT
13.08.2023 10:56:56
neopa C
Gruß Werner
.. , - ...
Intelligentes Transponieren mit Zuordnung von Überschriften
11.08.2023 19:05:16
daniel
Weils Spass macht, nochmal die Lösung mit den Formeln etwas beschleunigt
durch Sortieren kann man hier mit der schnellen Variante des SVerweises arbeiten.
läuft auch mit ca. 33.000 Zeilen in einer Sekunde durch.
auch hier ist alles auch von Hand nachvollziehbar 

Sub xxx()

Sheets("Tabelle2").Cells.Clear

    

With Sheets("Tabelle1")

    .UsedRange.Columns(1).Copy

    .Cells(1, 4).PasteSpecial xlPasteValues

    .Columns(4).RemoveDuplicates 1, xlNo

    .Cells(1, 4).CurrentRegion.Copy



    Sheets("Tabelle2").Cells(1, 1).PasteSpecial xlPasteValues, Transpose:=True



    .Rows(1).Insert

    With .Cells(2, 1).CurrentRegion.Resize(, 3).Offset(0, 4)

        .Columns(1).FormulaR1C1 = "=R[-1]C+(RC1=""Satzart"")"

        .Columns(2).FormulaR1C1 = "=Text(RC[-1],""00000"")&""|""&rC1"

        .Columns(3).FormulaR1C1 = "=RC2"

        .Formula = .Value

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

    End With

End With

With Sheets("Tabelle2")

    With .UsedRange.Offset(1, 0).Resize(WorksheetFunction.Max(Sheets("Tabelle1").Columns(5)))

        .FormulaR1C1 = "=IF(VLookUp(Text(Row()-1,""00000|"")&R1C,'Tabelle1'!C6:C7,1,1)=Text(Row()-1,""00000|"")&R1C," _

                        & "VLookUp(Text(Row()-1,""00000|"")&R1C,'Tabelle1'!C6:C7,2,1),"""")"

        .Formula = .Value

    End With

End With



With Sheets("tabelle1")

    .Range("C:G").ClearContents

    .Rows(1).Delete

End With



End Sub


Gruß Daniel
Anzeige
Intelligentes Transponieren mit Zuordnung von Überschriften
11.08.2023 20:18:27
daniel
HI
und noch eine Makrovariante,
diesmal ein Mix aus Formel und Array
auch ohne Sortierung ziemlich schnell, und immer noch ganz simpel und ohne komplexe funktionen: 

Sub Makro1()



Dim dat, erg

Dim z

With Sheets("Tabelle1")

    .Columns(1).Copy .Cells(1, 4)

    .Columns(4).RemoveDuplicates Columns:=1, Header:=xlNo

    .Range("A1").CurrentRegion.Copy

    .Range("F2").PasteSpecial xlPasteValues

    With .Range("F2").CurrentRegion.Resize(, 4)

        .Columns(3).FormulaR1C1 = "=R[-1]C+(""Satzart""=RC[-2])"

        .Columns(4).FormulaR1C1 = "=match(RC[-3],c4,0)"

        dat = .Value

        ReDim erg(1 To WorksheetFunction.Max(.Columns(3)), 1 To WorksheetFunction.Max(.Columns(4)))

        .Clear

    End With

    Sheets("Tabelle2").Cells.ClearContents

    With .Cells(1, 4).CurrentRegion

        .Copy

        Sheets("Tabelle2").Cells(1, 1).PasteSpecial xlPasteValues, Transpose:=True

        .Clear

    End With

End With



For z = 1 To UBound(dat, 1)

    erg(dat(z, 3), dat(z, 4)) = dat(z, 2)

Next

Sheets("Tabelle2").Cells(2, 1).Resize(UBound(erg, 1), UBound(erg, 2)) = erg



End Sub


gruß Daniel
Anzeige
Intelligentes Transponieren mit Zuordnung von Überschriften
11.08.2023 18:41:00
daniel
ist für große Datenmengen etwas langsam
besser erstmal im Array sammeln und nicht direkt ins Blatt eintragen. 

Sub Transponiern_schnell()

Dim dat, erg

Dim zD As Long

Dim zE As Long

Dim Üb As Object

Set Üb = CreateObject("scripting.dictionary")





dat = Sheets("Tabelle1").Cells(1, 1).CurrentRegion.Value

For zD = 1 To UBound(dat)

    If dat(zD, 1) = "Satzart" Then zE = zE + 1

    If Not Üb.exists(dat(zD, 1)) Then Üb(dat(zD, 1)) = Üb.Count + 1

Next

ReDim erg(0 To zE, 1 To Üb.Count)

zE = 0



For zD = 1 To UBound(dat, 1)

    If dat(zD, 1) = "Satzart" Then zE = zE + 1

    erg(zE, Üb(dat(zD, 1))) = dat(zD, 2)

Next



With Sheets("Tabelle2").Cells(1, 1)

    .Resize(UBound(erg, 1) + 1, UBound(erg, 2)) = erg

    .Resize(1, Üb.Count) = Üb.keys

End With

End Sub


gruß Daniel
Anzeige

Links zu Excel-Dialogen

Frame

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige