AW: Zellen um übergeordnete Informationen erweitern
25.06.2016 00:37:07
Matthias
Moin! Also hier jetzt mal eine Version, die wieder alle gesplitteten Daten einträgt. Ich habe mal versucht die Zugriffe auf das Tabellenblatt so gering wie möglich zu halten (kostet am meisten Zeit). Ein paar Möglichkeiten würde es noch geben. Würde dazu die Pfade aus dem ersten Teil komplett in den Zwischenspeicher packen und dort vergleichen. Das wird aber ziemlich groß ( um die 15 MB ) und ich weiß nicht, ob das für das System so günstig ist. Würde es deshalb erstmal so wie unten lösen. Habe den Code unten mal todesmutig auf einem Datensatz von 15500 Pfaden getestet. Waren jetzt nicht so komplizierte Pfade (da fehlt mir die Datenmenge) aber doch schon nen Haufen. Die Rechenzeit war fast exakt 10 Minuten. Wäre ja schonmal eine Steigerung zu 4 Stunden und Programmabbruch. Bitte mal wieder testen und melden, was passiert ist. Wenn wir eine Lauffähige Version, die deinen Vorstellungen entspricht, bastel ich auch eine auskommentierte, damit du nachvollziehen kannst, was der Code macht und ihn ggf. später mal anpassen kannst. VG
Option Explicit
Sub baum()
Dim letzter
Dim i As Long
Dim j As Long
Dim spalte As Long
Dim ende As Boolean
Dim vorher
Dim lange As Long
Dim weite As Long
Dim datensplit
Dim anztrenn
Dim k As Long
Dim wert
Dim wert2
Dim liste()
ReDim liste(0)
liste(0) = 0
lange = 1
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.Range(Columns(3), Columns(ActiveSheet.Columns.Count)).ClearContents
ActiveSheet.Range(Columns(3), Columns(ActiveSheet.Columns.Count)).NumberFormat = "@"
ActiveSheet.Cells(1, 3) = Time
letzter = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To letzter
If ActiveSheet.Cells(i, 1) "" Then
'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
If liste(2) = "" Then
liste(2) = liste(1)
liste(1) = ""
ende = True
End If
While ende = False
Set vorher = ActiveSheet.Columns(1).Find(Trim(liste(UBound(liste))), _
LookIn:=xlValues, Lookat:=xlWhole)
If Not vorher Is Nothing Then
If vorher.Offset(0, 1) "" Then
liste(0) = liste(0) + 1
ReDim Preserve liste(liste(0))
liste(liste(0)) = Trim(vorher.Offset(0, 1))
Else
ende = True
End If
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) = Trim(liste(j))
spalte = spalte + 1
Next j
End If
If liste(0) > lange Then lange = liste(0)
ReDim liste(0)
liste(0) = 0
End If
Next i
'Auflistung sortieren
ActiveSheet.Range("A2:" & Chr(66 + lange + 1) & letzter).Select
ActiveSheet.Sort.SortFields.Clear
For i = 1 To lange + 1
ActiveSheet.Sort.SortFields.Add Key:=Range(Chr(66 + i) & "2:" & Chr(66 + i) & _
letzter), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
Next i
With ActiveSheet.Sort
.SetRange ActiveSheet.Range("A2:" & Chr(66 + lange + 1) & letzter)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Cells(1, 1).Select
'der Teil für das gesplittet eintragen am Ende
spalte = lange + 4
For i = 2 To letzter
If ActiveSheet.Cells(i, 3) "" Then
If (ActiveSheet.Cells(i, 3) ActiveSheet.Cells(i - 1, 3) Or _
ActiveSheet.Cells(i, Columns.Count).End(xlToLeft).Column > weite) Then
weite = ActiveSheet.Cells(i, Columns.Count).End(xlToLeft).Column
Dim startliste
Dim zielliste
startliste = ActiveSheet.Range(ActiveSheet.Cells(i, 3), ActiveSheet.Cells(i, weite))
zielliste = startliste
If weite > 2 Then
zielliste(1, 1) = CStr(Trim(startliste(1, 1)))
For j = 2 To weite - 2
wert = startliste(1, j) ' aktueller Wert
wert2 = startliste(1, j - 1) ' der Vorgänger
If InStr(1, wert, wert2, vbTextCompare) > 0 Then
zielliste(1, j) = CStr(Mid(wert, Len(wert2) + 2, Len(wert)))
Else
Dim test
Dim anzabs
test = Split(wert, "-")
anzabs = 0
For k = 0 To UBound(test)
If InStr(1, wert2, test(k), vbTextCompare) = 0 Then
Exit For
End If
anzabs = anzabs + Len(test(k)) + 1
Next k
If anzabs = 0 Then
zielliste(1, j) = CStr(Mid(wert, InStr(1, wert, "-", _
vbTextCompare) + 1, Len(wert)))
Else
zielliste(1, j) = CStr(Mid(wert, anzabs + 1, Len(wert)))
End If
End If
Next j
ActiveSheet.Range(Cells(i, spalte), Cells(i, spalte + weite - 3)) = zielliste
End If
Else
ReDim Preserve zielliste(1 To 1, UBound(zielliste, 2) - 1)
weite = weite - 1
ActiveSheet.Range(Cells(i, spalte), Cells(i, spalte + weite - 3)) = zielliste
End If
End If
Next i
'#### Ende des Teiles zum splitten
ActiveSheet.Cells(1, 4) = Time
ActiveSheet.Range(Columns(3), Columns(ActiveSheet.Columns.Count)).Columns.AutoFit
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
