Strukturbaum auslesen aus Datensatz

[lubebi91]

Hallo,

es ist schon krass, wenn man den Unterschied zwischen dem Beispiel und der tatsächlichen Datenanordnung sieht, da kann ja keine Formel funktionieren!

 
Hallo,

Ich habe deine Formel nochmal auf den richtigen Datensätzen getestet. Es hat größtenteils auch gepasst! Die Idee war, villeicht kannst du mich korrigieren, dass ich die höchste Hierarchiestufe von links beginnt und die nächst darunter liegenden nach unten kopiert werden. 

Gruß
Für alle nochmal hier der Code mit dem mein Problem exakt gelöst wurde:

Code:

Sub Matthias_Michael()
Dim m As Long, i As Long, lr As Long, j As Long
Dim sPath As String, sFile As String, d As Variant
Dim sn As Variant, Tx As Variant, Ta As Variant
Dim abtnr As Variant, periodnr As Variant, allsold As Long
Dim aus0(0, 3) As Variant
' das ist ein Array, das erst mit Werten gefüllt und
' dann komplett geschrieben wird
Dim aM As Worksheet                   ' *** neu ***
Set aM = Sheets("Master")

' Application.DisplayAlerts = False
m = 1 'Zeile des Mastersheets
' sPath = "c:\users\dd\desktop\datenaufbereitung\"
sPath = "c:\A_Herber\Matthias\"
sFile = "*.xls"

sn = Split(CreateObject("wscript.shell").exec("cmd /c dir " & _
sPath & sFile & "/b/s").stdout.readall, vbCrLf)
 
' For i = 0 To UBound(sn): Debug.Print sn(i): Next

Stop
' stoppt die Abarbeitung des Skripts, mit F5 oder F8 geht's weiter
' An der Stelle kannst Du nachsehen, was im Debug-Fenster steht...

For Each d In sn
'   Debug.Print d
'   Stop
  ' hier auch ...
 
  If Len(d) > 0 Then
    Tx = Split(d, "\")
    Ta = Split(Tx(UBound(Tx)), "_")
    abtnr = Ta(0)
    periodnr = Ta(2)
    aus0(0, 0) = abtnr: aus0(0, 2) = periodnr
    Debug.Print "AbtNr = " & Ta(0), "PeriodNr = " & Ta(2)
    ' und was kommt hier?
'     Stop

    With Workbooks.Open(d)
        With .Sheets(1)
            If .Cells(1, 1) = "Alle Produkte bezahlt" Then _
               aus0(0, 1) = 1 Else aus0(0, 1) = 0

            lr = .Range("A" & .Rows.Count).End(xlUp).Row

            ' wieso erst ab 2? In der Datei ist keine Überschrift!
            For i = 1 To lr
              If InStr(1, .Range("C" & i), "Artikel") > 0 Then
'                  Stop
                 m = m + 1
                 aus0(0, 3) = Mid(.Range("C" & i), 9)
                 aM.Range("A" & m).Resize(1, UBound(aus0, 2) + 1) = aus0
               End If
            Next i
        End With
    .Close 0
    End With
    End If
  Next d
' Application.DisplayAlerts = True
End Sub

[lubebi91]

Sry Falscher CODE! Hier ist der richtige:

Code:

Sub baum()

Dim letzter
Dim i As Long
Dim j As Long
Dim spalte As Long
Dim ende As Boolean

Dim liste()

ReDim liste(0)
liste(0) = 0

letzter = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'i geht ab erstem Eintrag los
For i = 2 To letzter
   'werte suchen
   liste(0) = liste(0) + 2
   ReDim Preserve liste(liste(0))
   liste(1) = ActiveSheet.Cells(i, 1)
   liste(2) = ActiveSheet.Cells(i, 2)
   
   ende = False
   While ende = False
       Set vorher = ActiveSheet.Columns(1).Find(liste(UBound(liste)), LookIn:=xlValues)
       If Not vorher Is Nothing Then
           liste(0) = liste(0) + 1
           ReDim Preserve liste(liste(0))
           liste(liste(0)) = vorher.Offset(0, 1)
       Else
           ende = True
       End If
   Wend
   
   'werte eintragen
   spalte = 3
   If liste(0) > 0 Then
       For j = UBound(liste) To 1 Step -1
           ActiveSheet.Cells(i, spalte) = liste(j)
           spalte = spalte + 1
       Next j
   End If
   ReDim liste(0)
Next i
End Sub