Hierarchie Struktur aufbauen

Richi · 2020-07-06T18:58:31+00:00

Guten Tag Kann mir jemand helfen beim Aufbau einer Equipment-Hierarchie? Ausgangslage: Floc = Produkt NHA = Hext Higer Equipment (kann mehrere Male vorkommen und referenziert immer das nächst höhere Einzelteil) Equi = Einzelteil (Unique Teilenummer) Aufgrund des Equipment und der NHA möchte ich herausfinden in welcher Hierarchiestufe ein Einzelteil eingebaut ist ( Hierarchie) Als Einstig nach Floc sind die Einzelteile welche keinen Eintrag auf NHA hinterlegt haben) Die Teile in der Hierarchie-Stufe 1 konnte ich lösen, jedoch die suche über alle Hierarchistufen über NHA finde ich den einstieg nicht, wie ich die Teile in die richtige ebene bringe und die vorhergehenden spalten abfüllen kann. Beispiel: https://www.herber.de/bbs/user/138795.xlsx Mein Code: Sub Hierarchie() Dim wb As Workbook Dim wsQ As Worksheet Dim wsZ As Worksheet Dim i As Integer Dim a As Integer Dim lzQ As Long Set wb = ThisWorkbook Set wsQ = wb.Worksheets("Tabelle1") Set wsZ = wb.Worksheets("Tabelle4") lzQ = wsQ.Cells(wsQ.Rows.Count, "A").End(xlUp).Row 'Letzte Zeile Quelle With wsQ For i = 2 To lzQ 'Ab Zeile 2 bis letzte _ Zeile wsZ.Cells(i, 1) = wsQ.Cells(i, 1) 'Produkte Name in Spalte _ Floc schreiben If wsQ.Cells(i, 2) = "" Then 'Wenn NHA leer dann in _ Spalte Hier01 Equipment schreiben wsZ.Cells(i, 2) = wsQ.Cells(i, 3) End If Next i End With End Sub

Habe mir den Code zusammengestellt und es läuft. Bei mehr als 10000 Datensätze dauert es eine Ewigkeit bis das Programm durch ist. Kann mir jemand helfen den Code zu optimieren?
Option Explicit

Sub Hierarchie()
Dim wb As Workbook
Dim wsQ As Worksheet
Dim wsZ As Worksheet
Dim i As Integer
Dim a As Integer
Dim H10 As Integer
Dim H09 As Integer
Dim H08 As Integer
Dim H07 As Integer
Dim H06 As Integer
Dim H05 As Integer
Dim H04 As Integer
Dim H03 As Integer
Dim H02 As Integer
Dim H01 As Integer
Dim var09 As Long
Dim var08 As Long
Dim var07 As Long
Dim var06 As Long
Dim var05 As Long
Dim var04 As Long
Dim var03 As Long
Dim var02 As Long
Dim var01 As Long
Dim Equi As Long
Dim lzQ As Long                                                 'Variable Letzte Zeile
Dim rng As Range                                                'VAriableRange Suche
Set wb = ThisWorkbook
Set wsQ = wb.Worksheets("Tabelle1")
Set wsZ = wb.Worksheets("Hierarchie")
lzQ = wsQ.Cells(wsQ.Rows.Count, "A").End(xlUp).Row              'Letzte Zeile Quelle
Set rng = Range(Cells(2, 2), Cells(lzQ, 2))                     'Suchrange
'================================== Hierarchiestufe 9 & 10  ==== in Hierarchiestufe 10 alle  _
Equis und Hierarchiestufe 9 alle NHA Equis schreiben ==================================
With wsQ
For i = 2 To lzQ                                            'Ab Zeile 2 bis letzte  _
Zeile
wsZ.Cells(i, 1) = wsQ.Cells(i, 1)                       'Floc in Spalte A schreiben
wsZ.Cells(i, 11) = wsQ.Cells(i, 3)                  'Alle Equis in  _
Hierarchiestufe 10 schreiben
If wsQ.Cells(i, 2)  "" Then                           'Wenn NHA nicht leer ist  _
dann in Spalte Hierarchie 9 Equipment schreiben
wsZ.Cells(i, 11) = wsQ.Cells(i, 3)                  'Alle Equis in  _
Hierarchiestufe 10 schreiben                  '
wsZ.Cells(i, 10) = wsQ.Cells(i, 2)                  'Equis mit NHA NHA Equis in  _
Hierarchiestufe 9 schreiben
End If
Next i
End With
'================================== Hierarchiestufe 8 ==== alle Equis mit Eintrag in  _
Hierarchiestufe 9 Equis in Hierarchiestufe 10 suchen ==================================
For H09 = 2 To lzQ                                              '1. Loop
var09 = Range("J" & H09).Value                              'Equi Nummer in von jeder  _
Zelle in Hierarchie 9 lesen bis letzte Zeile
For H10 = 2 To lzQ                                          '2.Loop
Equi = Range("K" & H10).Value                           'Equi Nummer in von jeder  _
Zelle in Hierearchie 10 (Basis)lesen bis letzte Zeile
If var09 = Equi Then                                    'Equi Nummer vergeleichen  _
Hierarchie 9 mit Hierarchie 10
If wsZ.Cells(H09, 10) = "" Then                     'Kein Eintrag in  _
Hierarchiestufe 9 nichts machen
End If
If wsZ.Cells(H09, 10)  "" Then                        'Equi aus Hierarchiestufe 9  _
und 10 sind gleich
wsZ.Cells(H09, 9) = wsZ.Cells(H10, 10)              'In Zelle Hierarchiestufe 8  _
Equi aus Hierarchiestufe 9 (Adresse aus 2. Loop) schreiben
End If
End If
Next H10
H10 = 2                                                     'Zähler von 2. Loop zurü _
ckstellen
Next H09
If wsZ.Cells(wsZ.Rows.Count, "I").End(xlUp).Row = 1 Then        'Letzte Zeile Quelle
Exit 

Sub                                                    'Programm beenden
End If
'================================== Hierarchiestufe 7 ==== alle Equis mit Eintrag in  _
Hierarchiestufe 8 Equis in Hierarchiestufe 10 suchen ==================================
For H08 = 2 To lzQ                                              '1. Loop
var08 = Range("I" & H08).Value                              'Equi Nummer in von jeder  _
Zelle in Hierarchie 8 lesen bis letzte Zeile
For H09 = 2 To lzQ                                          '2.Loop
Equi = Range("K" & H09).Value                           'Equi Nummer in von jeder  _
Zelle in Hierearchie 10(Basis) lesen bis letzte Zeile
If var08 = Equi Then                                    'Equi Nummer vergeleichen  _
Hierarchie 8 mit Hierarchie 9
If wsZ.Cells(H08, 9) = "" Then                      'Kein Eintrag in  _
Hierarchiestufe 8 nichts machen
End If
If wsZ.Cells(H08, 9)  "" Then                         'Equi aus Hierarchiestufe 8  _
und 9 sind gleich
wsZ.Cells(H08, 8) = wsZ.Cells(H09, 10)              'In Zelle Hierarchiestufe 7  _
Equi aus Hierarchiestufe 9 (Adresse aus 2. Loop) schreiben
End If
End If
Next H09
H09 = 2                                                     'Zähler von 2. Loop zurü _
ckstellen
Next H08
If wsZ.Cells(wsZ.Rows.Count, "H").End(xlUp).Row = 1 Then        'Letzte Zeile Quelle
Exit 

Sub                                                    'Programm beenden
End If
'================================== Hierarchiestufe 6 ==== alle Equis mit Eintrag in  _
Hierarchiestufe 7 Equis in Hierarchiestufe 10 suchen ==================================
For H07 = 2 To lzQ                                              '1. Loop
var07 = Range("H" & H07).Value                              'Equi Nummer in von jeder  _
Zelle in Hierarchie 7 lesen bis letzte Zeile
For H08 = 2 To lzQ                                          '2.Loop
Equi = Range("K" & H08).Value                           'Equi Nummer in von jeder  _
Zelle in Hierearchie 10(Basis) lesen bis letzte Zeile
If var07 = Equi Then                                    'Equi Nummer vergeleichen  _
Hierarchie 7 mit Hierarchie 8
If wsZ.Cells(H07, 8) = "" Then                      'Kein Eintrag in  _
Hierarchiestufe 8 nichts machen
End If
If wsZ.Cells(H07, 8)  "" Then                         'Equi aus Hierarchiestufe 7  _
und 8 sind gleich
wsZ.Cells(H07, 7) = wsZ.Cells(H08, 10)              'In Zelle Hierarchiestufe 6  _
Equi aus Hierarchiestufe 9 (Adresse aus 2. Loop) schreiben
End If
End If
Next H08
H08 = 2                                                     'Zähler von 2. Loop zurü _
ckstellen
Next H07
If wsZ.Cells(wsZ.Rows.Count, "G").End(xlUp).Row = 1 Then        'Letzte Zeile Quelle
Exit 

Sub                                                    'Programm beenden
End If
'================================== Hierarchiestufe 5 ==== alle Equis mit Eintrag in  _
Hierarchiestufe 6 Equis in Hierarchiestufe 10 suchen ==================================
For H06 = 2 To lzQ                                              '1. Loop
var06 = Range("G" & H06).Value                              'Equi Nummer in von jeder  _
Zelle in Hierarchie 6 lesen bis letzte Zeile
For H07 = 2 To lzQ                                          '2.Loop
Equi = Range("K" & H07).Value                           'Equi Nummer in von jeder  _
Zelle in Hierearchie 10(Basis) lesen bis letzte Zeile
If var06 = Equi Then                                    'Equi Nummer vergeleichen  _
Hierarchie 6 mit Hierarchie 7
If wsZ.Cells(H06, 7) = "" Then                      'Kein Eintrag in  _
Hierarchiestufe 7 nichts machen
End If
If wsZ.Cells(H06, 7)  "" Then                         'Equi aus Hierarchiestufe 6  _
und 7 sind gleich
wsZ.Cells(H06, 6) = wsZ.Cells(H07, 10)              'In Zelle Hierarchiestufe 5  _
Equi aus Hierarchiestufe 9 (Adresse aus 2. Loop) schreiben
End If
End If
Next H07
H07 = 2                                                     'Zähler von 2. Loop zurü _
ckstellen
Next H06
If wsZ.Cells(wsZ.Rows.Count, "F").End(xlUp).Row = 1 Then        'Letzte Zeile Quelle
Exit 

Sub                                                    'Programm beenden
End If
'================================== Hierarchiestufe 4 ==== alle Equis mit Eintrag in  _
Hierarchiestufe 5 Equis in Hierarchiestufe 10 suchen ==================================
For H05 = 2 To lzQ                                              '1. Loop
var05 = Range("F" & H05).Value                              'Equi Nummer in von jeder  _
Zelle in Hierarchie 5 lesen bis letzte Zeile
For H06 = 2 To lzQ                                          '2.Loop
Equi = Range("K" & H06).Value                           'Equi Nummer in von jeder  _
Zelle in Hierearchie 10(Basis) lesen bis letzte Zeile
If var05 = Equi Then                                    'Equi Nummer vergeleichen  _
Hierarchie 5 mit Hierarchie 6
If wsZ.Cells(H05, 6) = "" Then                      'Kein Eintrag in  _
Hierarchiestufe 6 nichts machen
End If
If wsZ.Cells(H05, 6)  "" Then                         'Equi aus Hierarchiestufe 5  _
und 6 sind gleich
wsZ.Cells(H05, 5) = wsZ.Cells(H06, 10)              'In Zelle Hierarchiestufe 4  _
Equi aus Hierarchiestufe 9 (Adresse aus 2. Loop) schreiben
End If
End If
Next H06
H06 = 2                                                     'Zähler von 2. Loop zurü _
ckstellen
Next H05
If wsZ.Cells(wsZ.Rows.Count, "E").End(xlUp).Row = 1 Then        'Letzte Zeile Quelle
Exit 

Sub                                                    'Programm beenden
End If
'================================== Hierarchiestufe 3 ==== alle Equis mit Eintrag in  _
Hierarchiestufe 4 Equis in Hierarchiestufe 10 suchen ==================================
For H04 = 2 To lzQ                                              '1. Loop
var04 = Range("E" & H04).Value                              'Equi Nummer in von jeder  _
Zelle in Hierarchie 4 lesen bis letzte Zeile
For H05 = 2 To lzQ                                          '2.Loop
Equi = Range("K" & H05).Value                           'Equi Nummer in von jeder  _
Zelle in Hierearchie 10(Basis) lesen bis letzte Zeile
If var04 = Equi Then                                    'Equi Nummer vergeleichen  _
Hierarchie 4 mit Hierarchie 5
If wsZ.Cells(H04, 5) = "" Then                      'Kein Eintrag in  _
Hierarchiestufe 5 nichts machen
End If
If wsZ.Cells(H04, 5)  "" Then                         'Equi aus Hierarchiestufe 4  _
und 5 sind gleich
wsZ.Cells(H04, 4) = wsZ.Cells(H05, 10)              'In Zelle Hierarchiestufe 3  _
Equi aus Hierarchiestufe 9 (Adresse aus 2. Loop) schreiben
End If
End If
Next H05
H05 = 2                                                     'Zähler von 2. Loop zurü _
ckstellen
Next H04
If wsZ.Cells(wsZ.Rows.Count, "D").End(xlUp).Row = 1 Then        'Letzte Zeile Quelle
Exit 

Sub                                                    'Programm beenden
End If
'================================== Hierarchiestufe 2 ==== alle Equis mit Eintrag in  _
Hierarchiestufe 3 Equis in Hierarchiestufe 10 suchen ==================================
For H03 = 2 To lzQ                                              '1. Loop
var03 = Range("D" & H03).Value                              'Equi Nummer in von jeder  _
Zelle in Hierarchie 3 lesen bis letzte Zeile
For H04 = 2 To lzQ                                          '2.Loop
Equi = Range("K" & H04).Value                           'Equi Nummer in von jeder  _
Zelle in Hierearchie 10(Basis) lesen bis letzte Zeile
If var03 = Equi Then                                    'Equi Nummer vergeleichen  _
Hierarchie 3 mit Hierarchie 4
If wsZ.Cells(H03, 4) = "" Then                      'Kein Eintrag in  _
Hierarchiestufe 4 nichts machen
End If
If wsZ.Cells(H03, 4)  "" Then                         'Equi aus Hierarchiestufe 3  _
und 4 sind gleich
wsZ.Cells(H03, 3) = wsZ.Cells(H04, 10)              'In Zelle Hierarchiestufe 2  _
Equi aus Hierarchiestufe 9 (Adresse aus 2. Loop) schreiben
End If
End If
Next H04
H04 = 2                                                     'Zähler von 2. Loop zurü _
ckstellen
Next H03
If wsZ.Cells(wsZ.Rows.Count, "C").End(xlUp).Row = 1 Then        'Letzte Zeile Quelle
Exit 

Sub                                                    'Programm beenden
End If
'================================== Hierarchiestufe 1 ==== alle Equis mit Eintrag in  _
Hierarchiestufe 2 Equis in Hierarchiestufe 10 suchen ==================================
For H02 = 2 To lzQ                                              '1. Loop
var02 = Range("C" & H03).Value                              'Equi Nummer in von jeder  _
Zelle in Hierarchie 2 lesen bis letzte Zeile
For H03 = 2 To lzQ                                          '2.Loop
Equi = Range("K" & H03).Value                           'Equi Nummer in von jeder  _
Zelle in Hierearchie 10(Basis) lesen bis letzte Zeile
If var02 = Equi Then                                    'Equi Nummer vergeleichen  _
Hierarchie 2 mit Hierarchie 3
If wsZ.Cells(H02, 3) = "" Then                      'Kein Eintrag in  _
Hierarchiestufe 3 nichts machen
End If
If wsZ.Cells(H02, 3)  "" Then                         'Equi aus Hierarchiestufe 2  _
und 3 sind gleich
wsZ.Cells(H02, 2) = wsZ.Cells(H03, 10)              'In Zelle Hierarchiestufe 1  _
Equi aus Hierarchiestufe 9 (Adresse aus 2. Loop) schreiben
End If
End If
Next H03
H03 = 2                                                     'Zähler von 2. Loop zurü _
ckstellen
Next H02
If wsZ.Cells(wsZ.Rows.Count, "B").End(xlUp).Row = 1 Then        'Letzte Zeile Quelle
Exit 

Sub                                                    'Programm beenden
End If
End Sub

Hallo Richi,
ich habe das Makro angepasst, so dass bei leeren "ÜbergEqu" die Spalte "Hier_1" leer bleibt.
Ich hab gesehen, das in der Ursprungsliste in den Spaltem "ÜbergEqu" und "Equipment" die Zahlen als Text stehen.
Ich hab das Aufteilen der Ergebniswerte in Spalten angepasst, so dass die Zahlen als Texte erhalten bleiben. Ist wichtig bei Zahlen mit führenden Nullen oder wenn die Ziffernfolge Richtung 15 Ziffern enthält, da Excel dann die Zahlendarstellung anpasst.
LG
Franz

Sub Hierarchie()
Dim wksQ As Worksheet
Dim ZeiQ As Long, ZeiQ1 As Long, zei1 As Long, zei2 As Long, zeiQL As Long
Dim wksZ As Worksheet
Dim ZeiZ As Long
Dim strFloc As String
Dim strHierarchie As String, bolH As Boolean
Dim varNHA, varEqui
Dim arrData, arrH() As String
Set wksQ = ActiveWorkbook.Worksheets("Tabelle1") 'Blatt mit Ausgangsliste
Set wksZ = ActiveWorkbook.Worksheets("Hierarchie") 'Blatt für Hierarchie
With wksZ
ZeiZ = .Cells(.Rows.Count, 1).End(xlUp).Row
If ZeiZ > 1 Then
'Altdaten ggf. löschen
.Range(.Rows(2), .Rows(ZeiZ)).Clear
End If
End With
With wksQ
'Zeile mit Spaltentitel in Ausgangsliste
ZeiQ = 1
zei1 = ZeiQ + 1 'Zeile mit 1. Hierarchie
'letzte zeile in Ausgangsliste
zeiQL = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Daten der Spalte A bis C in Array laden
arrData = .Range(.Cells(1, 1), .Cells(zeiQL, 3))
ZeiZ = zei1 'Startzeile für Ergebnis-Array
'Ergebnis-Array dimensionieren
ReDim arrH(zei1 To zeiQL, 1 To 1)
Do
strFloc = arrData(zei1, 1) '1. Floc merken
zei2 = zei1
Do
'letzte Zeile mit gleicher Floc suchen
If arrData(zei2 + 1, 1)  strFloc Then
Do
'Zeilen im Block abarbeiten
ZeiQ = ZeiQ + 1
If ZeiQ > zeiQL Then Exit Do
varNHA = arrData(ZeiQ, 2)
varEqui = arrData(ZeiQ, 3)
If IsEmpty(varNHA) Then
strHierarchie = ";" & varEqui   'geänderte Zeile 2020-07-09 fcs
Else
strHierarchie = varNHA & ";" & varEqui
'Iterativ prüfen, ob NHA in Equi vorkommt und Ergebnis zusammenstellen
Do
bolH = False 'Merker, das keine übergeordnete Hierarchie mehr _
vorhanden
For ZeiQ1 = zei1 To zei2
varEqui = arrData(ZeiQ1, 3)
If varNHA = varEqui And Not IsEmpty(arrData(ZeiQ1, 2)) Then
varNHA = arrData(ZeiQ1, 2)
strHierarchie = varNHA & ";" & strHierarchie
bolH = True 'übergeordnete Hierarchie vorhanden
Exit For
End If
Next
If bolH = False Then Exit Do
Loop
End If
'Floc an Anfang des Ergebnissses stellen
strHierarchie = strFloc & ";" & strHierarchie
'Ergebnis eintragen
arrH(ZeiZ, 1) = strHierarchie
'nächste Zielzeile setzen
ZeiZ = ZeiZ + 1
Loop Until ZeiQ = zei2 'letzte Zeile des Floc-Blocks erreicht
zei1 = zei2 + 1
Exit Do 'nächsten Floc-Block abarbeiten
End If
zei2 = zei2 + 1
Loop
Loop Until zei1 = zeiQL 'letzte Zeile des letzten Floc-Blocks erreicht
End With
With wksZ
Application.ScreenUpdating = False
'Ergebnis-Array in Zieltabelle eintragen
.Cells(2, 1).Resize(UBound(arrH) - LBound(arrH) + 1, 1) = arrH
'letzte Zeile
ZeiZ = .Cells(.Rows.Count, 1).End(xlUp).Row
'in Spalte A eingetragene Ergebnisse am ";" in Spalten aufteilen
Dim iK As Integer
'geänderter Code zum Slitten des Textes in Spalten  2020-07-09 fcs
'Format für Text in Spalten aufteilen
iK = 2 '1 = Standard (Excel legt fest), 2 = Text
.Range(.Cells(2, 1), .Cells(ZeiZ, 1)).TextToColumns Destination:=.Range("A2"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, _
FieldInfo:=Array(Array(1, iK), Array(2, iK), Array(3, iK), Array(4, iK), _
Array(5, iK), Array(6, iK), Array(7, iK), Array(8, iK), Array(9, iK), _
Array(10, iK), Array(11, iK), Array(12, iK)), _
TrailingMinusNumbers:=True
Application.ScreenUpdating = True
End With
End Sub

Forumthread: Hierarchie Struktur aufbauen

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Hierarchie Struktur aufbauen

Forumthread: Hierarchie Struktur aufbauen

25 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread