PDA

Vollständige Version anzeigen : "Handgeschriebene" Baumstrucktur in Liste umwandeln


Meister_Knobi
13.07.2014, 20:29
Hallo,

ich möchte eine Baumstrucktur, in der ich Kategorien angelegt habe mit ihren abhännigkeit zur Überkategorie in eine Liste Umwandeln.
Den Text habe ich manuell in der Baumstrucktur angeordnet. Die IDs werden bereits automatisch erstellt und angepasst.
Hier ein beispiel:76246

Diese Anordung möchte ich nun mit Ihren Abhännigkeiten in eine Simple Liste , mit den Spaltenüberschrifften Kat-ID, ÜberKat-ID, Kat-Name und ÜberKat-Name, übernehmen, um sie spähter in eine Datenbank zu übernehmen.

Ich bekomme es überhaupt nicht hin dies zu Automatisieren. Dies würde mir nur viel zeit sparen, da die Baumstrucktur mehr als 500 Zeilen und und 20 Spalten Groß ist.

Ich hoffe hier kann mir jemand helfen. VBA konnte ich auch mal nur ist das schon lange her und ich bin eingerostet, wenn mir jemand ne vorlage gibt, kann ich villeicht was Basteln.

Mc Santa
14.07.2014, 08:50
Hallo,

ich kann dir folgenden Code anbieten, im Anhang ist auch eine Demo-Datei:
Option Explicit


Sub BaumstrukturAuslesen()
Dim wsSrc As Worksheet, wsTar As Worksheet
Dim rng As Range
Dim lastrow As Long

Set wsSrc = Worksheets("Quelle")
Set wsTar = Worksheets("Ausgabe")
With wsTar
.Cells.Clear
.Range(.Cells(1, 1), .Cells(1, 4)) = Array("Kat-ID", "ÜberKat-ID", "Kat-Name", "ÜberKat-Name")

For Each rng In wsSrc.UsedRange
If rng.Value <> "" Then
If rng.Column Mod 2 = 1 Then

lastrow = .Cells(Rows.Count, 3).End(xlUp).Row
If rng.Column = 1 Then
.Range(.Cells(lastrow + 1, 1), .Cells(lastrow + 1, 4)) = Array(rng.Value, "leer", rng.Offset(, 1), "leer")
Else
If rng.Offset(, -1) <> "" Then
.Range(.Cells(lastrow + 1, 1), .Cells(lastrow + 1, 4)) = Array(rng, rng.Offset(, -2), rng.Offset(, 1), rng.Offset(, -1))
Else
.Range(.Cells(lastrow + 1, 1), .Cells(lastrow + 1, 4)) = Array(rng, rng.Offset(, -2).End(xlUp), rng.Offset(, 1), rng.Offset(, -1).End(xlUp))
End If
End If

End If
End If
Next rng
End With
End Sub

Damit der Code richtig funktioniert, müssen deine Quelldaten in A1 anfangen und so aussehen, wie auf deinem Bild. Außerdem müssen die leeren Zellen tatsählich leer sein, das heißt, dass dort keine Formel stehen darf, die nur eine leere Ausgabe erzeugt.

Falls etwas nicht wie gewünscht funktioniert, oder du Fragen zum Code hast, dann melde dich gerne wieder hier.
Und ich freue mich natürlich über Feedback, wenn alles geht :)

VG

Meister_Knobi
14.07.2014, 12:47
Das Makro ist herlich!

Irgendwie kommt es mir so vor als ob du auf diese Aufgabenstellung gewartet hast. :D

Einen kleinen Fehler hat das aber noch. In manchen Fällen wird die ÜberKat-ID nicht ausgegeben. Jedoch ist der ÜberKat-Name korrekt. Wenn es auftritt dann schon nach einem bestimmten musster, aber wenn ich die Strucktur wieder etwas änder fehlen die ÜberKat-IDs wo anders. Ich blick da nicht genau durch

Hier ein beispiel: 76266

Mc Santa
14.07.2014, 13:05
Hallo,

bitte setze den markierten Code in dein Makro ein:

Set wsSrc = Worksheets("Quelle")
Set wsTar = Worksheets("Ausgabe")

With wsSrc
.UsedRange.Replace What:="", Replacement:="*", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.UsedRange.Replace What:="~*", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With

With wsTar
.Cells.Clear
Das Problem war, dass einige Zellen nicht wirklich leer waren, ob wohl sie so aussehen. (Vielleicht hast du deine Baumstruktur importiert? Dann entsteht das manchmal)

Um dir zu zeigen, was ich meine (in der alten Datei):
Gehe einmal in Zelle B15 und drücke STRG + Pfeil nach oben Nun gehe in Zelle A15 und mache das gleiche.
Deshalb wird der Name richtig ausgegeben, aber die Kategorie nicht.

Hilft dir das nun weiter?
VG

PS: Mit der gleichen Begründung hatten sogar alle Einträge eine falsche ÜberKat-ID. Auch dieser Fehler ist durch den zusätzlichen Code behoben.

Meister_Knobi
14.07.2014, 15:49
Da die IDs per Formel erstellt werden habe ich die lediglich die werte in die Mappe eingefügt und das Ergebniss wieder kopiert.

Das in manchen Zellen ein Leerzeichen vorkommt, und die zelle somit nicht leer ist tut mir leid. Ich war nicht der einzige der Die mappe bearbeitet hat.

Jetzt scheint aber alles zu Funktioniern. Danke dafür.

Ich versteh den Code aber nicht. Wäre es möglich das du ihn noch mit Kommentaren versiehts?

Mc Santa
14.07.2014, 16:10
Hallo,

in de Zellen war kein Leerzeichen, sie sind zwar leer, aber Excel erkennt sie nicht als leer. Es ist etwas komisch, warum das geanu so ist, weiß ich nicht. Ich weiß aber, dass ich das manchmal das gleiche Problem habe, wenn ich Daten importiere.
Ist also nicht als dein Fehler zu interpretieren :)

Ich kann heute Abend ein bisschen was dazu schreiben. Im wesentlichen geht der Code jeden Eintrag durch und kopiert ihn in die Ausgabe. Dazu die Kategrie links daneben. Falls dort nichts steht, "springt" der Code in die nächste Zelle nach oben, bis es einen Eintrag gibt.
Ausnahme ist Spalte 1, da es hier keine ÜberKat gibt.

VG

Mc Santa
14.07.2014, 20:45
Hallo,

ich habe hier den Code etwas kommentiert:

Sub BaumstrukturAuslesen()
Dim wsSrc As Worksheet, wsTar As Worksheet
Dim rng As Range
Dim lastrow As Long

Set wsSrc = Worksheets("Quelle") 'speichert das Quelldatenblatt in einer Variable
Set wsTar = Worksheets("Ausgabe") 'speichert das Zieldatenblatt in einer Variable

With wsSrc
'sorgt dafür, dass einfach und vor allem schneller auf das Tabbellenblatt zugegriffen werden kann
'immer, wenn jetzt ein . (Punkt) benutzt wird, bezieht es sich auf die Variable wsSrc
' .Cells(1, 1) entspricht wsSrc.Cells(1, 1)

'ersetze alle "" (leeren Zellen) durch * (Stern)
.UsedRange.Replace What:="", Replacement:="*", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

'ersetze alle * (Stern) durch "" (leerer Text)
'hier muss man etwas tricksen: sucht man nur nach * (Stern) findet man ALLE Zellen.
'Wenn man nur Zellen mit * (Stern) finden, muss man nach ~* (Tilde Stern) suchen.
.UsedRange.Replace What:="~*", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With

With wsTar 'Zieltabellenblatt
.Cells.Clear 'lösche alle Zelleinträge

'schreibe eine Überschrift:
'.Range(.Cells(1, 1), .Cells(1, 4)) ist der Bereich von Zelle A1 bis Zelle D1
'über einen Array befülle ich die Zelle. Man könnte das auch einzeln machen, aber über einen Arry ist es schneller
.Range(.Cells(1, 1), .Cells(1, 4)) = Array("Kat-ID", "ÜberKat-ID", "Kat-Name", "ÜberKat-Name")



For Each rng In wsSrc.UsedRange 'gehe alle Zellen im Quelldatenblatt einzeln durch
If rng.Value <> "" Then 'Wenn in der aktuellen Zelle etwas steht
If rng.Column Mod 2 = 1 Then 'Wenn die aktuelle Spalte ungerade ist (sonst würde ich die ID und den Namen einzeln abfragen. So gehe ich nur alle IDs durch)

lastrow = .Cells(Rows.Count, 3).End(xlUp).Row 'bestimme die letzte Zeile im Zieldatenblatt

'jetzt werden die Daten kopiert, das läuft immer nach einem ähnlichen Schema ab, wobei es einige unterschiedliche Fälle gibt

'Range: 1.Spalte / letzte Reihe + 1 bis 4.Spalte / letzte Reihe + 1
'Inhalt: ein Array mit folgenden Inhalten: (Array("Kat-ID", "ÜberKat-ID", "Kat-Name", "ÜberKat-Name")

If rng.Column = 1 Then 'Falls Spalte 1, dann Sonderhandlung: hier gibt es kein ÜberKategorie
'in rng steht die aktuelle ID
'rechts daneben steht der aktuelle Name. Ich rufe die Zelle rechts daneben über Offset(,1) ab --> rng.offset(,1)
.Range(.Cells(lastrow + 1, 1), .Cells(lastrow + 1, 4)) = Array(rng, "leer", rng.Offset(, 1), "leer")
Else
If rng.Offset(, -1) <> "" Then 'in der Zelle links daneben steht etwas, das ist dann direkt die ÜberKategorie
'rng = aktuelle ID
'rng.offset(,-2) = Zelle zwei nach links --> ÜberKat-ID
'rng.offset(,1) = Zelle eins nach rechts --> Kat-Name
'rngoffset(,-1) = Zelle eins nach links --> ÜberKat-Name
.Range(.Cells(lastrow + 1, 1), .Cells(lastrow + 1, 4)) = Array(rng, rng.Offset(, -2), rng.Offset(, 1), rng.Offset(, -1))
Else 'in der Zelle nach links steht nichts, ich muss als die nächste nichtleere Zelle darüber suchen

'rng.Offset(,-2).End(xlup) = die aktuelle Zelle, zwei nach links, und dann so weit nach oben bis es eine gefülle Zelle gibt
'andere Einträge analog
.Range(.Cells(lastrow + 1, 1), .Cells(lastrow + 1, 4)) = Array(rng, rng.Offset(, -2).End(xlUp), rng.Offset(, 1), rng.Offset(, -1).End(xlUp))
End If
End If
End If
End If
Next rng
End With
End Sub

Ich hoffe es hilft dir, Fragen gerne :)

VG

Meister_Knobi
15.07.2014, 08:49
Ja Danke das hilft mir sehr.

Habe früher VBA unabhänig von Excel genutzt. Also leere Tabellenblätter und nur ein Paar Userforms dahinter. Die Kommunikation von Tabelle und Code ist mir neu.

Danke für die schnelle Hilfe. Hat mir einigs an geschuffte erspart