Ich habe hier ein Bsp. gefunden
Die Datei https://www.herber.de/bbs/user/105756.xlsm wurde aus Datenschutzgründen gelöscht
nur das geht nur bis zur dritten Spalte .
Gibt es da ein Möglichkeit diese Dynamisch zu gestallten ?
Gruß Basti
Die Datei https://www.herber.de/bbs/user/105756.xlsm wurde aus Datenschutzgründen gelöscht
Private Sub CommandButton1_Click()
Dim wkb As Workbook, wks As Worksheet
Dim ndeMain As MSComctlLib.node, ndeMain1 As MSComctlLib.node
Dim iCounter As Integer, nAnzahl1 As Long, nAnzahl2 As Long
Dim dic1 As Object, dic2 As Object
Dim sWert1 As String, sWert2 As String, swert3 As String
Set wkb = ThisWorkbook
Set wks = wkb.Worksheets("Autos")
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
With Me.TreeView1
.Nodes.Clear
.LineStyle = tvwRootLines
'Hauptknoten
Set ndeMain = .Nodes.Add(, , Key:=Replace(wkb.Name, " ", "_", 1, -1, vbTextCompare), _
Text:=wkb.Name)
'ndeMain.Tag = wkb.Name & "~" & wkb.Worksheets(1).Name & "~" & wkb.Worksheets(1).Cells( _
1, 1).Address
With wks
'letzte beschriebene Zeile in Tabelle 'Autos' & Spalte 'A'
nAnzahl1 = wks.Cells(.Rows.Count, 1).End(xlUp).Row
End With
'ab Zeile '3'
For nAnzahl2 = 3 To nAnzahl1
'Spalte 'A'
sWert1 = wks.Cells(nAnzahl2, 1).Value
'Key-Werte im Treeview dürfen kein Leerzeichen enthalten
sWert2 = Replace(sWert1, " ", "_", 1, -1, vbTextCompare)
If Not dic1.exists(sWert2) Then
dic1.Add sWert2, sWert1
Set ndeMain1 = .Nodes.Add(ndeMain.Key, 4, Key:=sWert2, Text:=sWert1)
Else
Set ndeMain1 = .Nodes(sWert2)
End If
ndeMain1.Sorted = True
'Spalte 'B'
sWert1 = wks.Cells(nAnzahl2, 2).Value
'Key-Werte im Treeview dürfen kein Leerzeichen enthalten
sWert2 = Replace(sWert1, " ", "_", 1, -1, vbTextCompare)
If Not dic2.exists(swert3 & "~" & sWert2) Then
dic2.Add swert3 & "~" & sWert2, sWert1
Set ndeMain1 = .Nodes.Add(ndeMain1.Key, 4, Key:=swert3 & "~" & sWert2, Text:= _
sWert1)
Else
Set ndeMain1 = .Nodes(swert3 & "~" & sWert2)
End If
ndeMain1.Sorted = True
'Spalte 'E'
sWert1 = wks.Cells(nAnzahl2, 3).Value
'Key-Werte im Treeview dürfen kein Leerzeichen enthalten
sWert2 = Replace(sWert1, " ", "_", 1, -1, vbTextCompare)
iCounter = iCounter + 1
Set ndeMain1 = .Nodes.Add(ndeMain1.Key, 4, Key:=sWert2 & "~" & iCounter, Text:= _
sWert1)
ndeMain1.Sorted = True
Next nAnzahl2
ndeMain.Expanded = True
ndeMain.Sorted = True
End With
Set ndeMain = Nothing: Set ndeMain1 = Nothing
Set wks = Nothing
Set wkb = Nothing
End Sub
Private Sub CommandButton1_Click()
Dim wkb As Workbook, wks As Worksheet
Dim ndeMain As MSComctlLib.Node, ndeMain1 As MSComctlLib.Node
Dim iCounter As Integer, nAnzahl1 As Long, nAnzahl2 As Long
'Dim dic1 As Object, dic2 As Object, dic3 As Object, dic4 As Object
Dim sWert1 As String, sWert2 As String, swert3 As String
Set wkb = ThisWorkbook
Set wks = wkb.Worksheets("Autos")
' Set dic1 = CreateObject("Scripting.Dictionary")
'Set dic2 = CreateObject("Scripting.Dictionary")
'Set dic3 = CreateObject("Scripting.Dictionary")
'Set dic4 = CreateObject("Scripting.Dictionary")
'Set dic5 = CreateObject("Scripting.Dictionary")
With Me.TreeView1
.Nodes.Clear
.LineStyle = tvwRootLines
'Hauptknoten
Set ndeMain = .Nodes.Add(, , Key:=Replace(wkb.Name, " ", "_", 1, -1, vbTextCompare), _
Text:=wkb.Name)
'ndeMain.Tag = wkb.Name & "~" & wkb.Worksheets(1).Name & "~" & wkb.Worksheets(1).Cells( _
1, 1).Address
With wks
'letzte beschriebene Zeile in Tabelle 'Autos' & Spalte 'A'
nAnzahl1 = wks.Cells(.Rows.Count, 1).End(xlUp).Row
End With
'ab Zeile '3'
For nAnzahl2 = 3 To nAnzahl1
' Spalte A bis E
Dim h As Long
For h = 1 To 5
Dim dic(h) As Object
Set dic(h) = CreateObject("Scripting.Dictionary")
sWert1 = wks.Cells(nAnzahl2, 1).Value
If sWert1 = "" Then GoTo Ende
'Key-Werte im Treeview dürfen kein Leerzeichen enthalten
sWert2 = Replace(sWert1, " ", "_", 1, -1, vbTextCompare)
swert3 = sWert2
If Not dic1.exists(sWert2) Then
dic1.Add sWert2, sWert1
Set ndeMain1 = .Nodes.Add(ndeMain.Key, 4, Key:=sWert2, Text:=sWert1)
Else
Set ndeMain1 = .Nodes(sWert2)
End If
ndeMain1.Sorted = True
Next h
'Spalte 'F'
sWert1 = wks.Cells(nAnzahl2, 5).Value
'fehlende Angaben iin der Spalte 'D' nicht verwerten
If Trim(sWert1) "" Then
'Key-Werte im Treeview dürfen kein Leerzeichen enthalten
swert3 = Replace(sWert1, " ", "_", 1, -1, vbTextCompare)
iCounter = iCounter + 1
Set ndeMain1 = .Nodes.Add(ndeMain1.Key, 4, Key:=sWert2 & "~" & iCounter, Text:= _
sWert1)
ndeMain1.Sorted = True
End If
Ende:
Next nAnzahl2
ndeMain.Expanded = True
ndeMain.Sorted = True
End With
Set ndeMain = Nothing: Set ndeMain1 = Nothing
Set wks = Nothing
Set wkb = Nothing
End Sub
Private Sub CommandButton1_Click()
Dim wkb As Workbook, wks As Worksheet
Dim ndeMain As MSComctlLib.Node, ndeMain1 As MSComctlLib.Node
Dim iCounter As Integer, nAnzahl1 As Long, nAnzahl2 As Long, nAnzahlS1 As Long, h As Long
Dim dic1 As Object, dic2 As Object ', dic3 As Object, dic4 As Object
Dim sWert1 As String, sWert2 As String, swert3 As String
Set wkb = ThisWorkbook
Set wks = wkb.Worksheets("Autos")
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
'Set dic3 = CreateObject("Scripting.Dictionary")
'Set dic4 = CreateObject("Scripting.Dictionary")
'Set dic5 = CreateObject("Scripting.Dictionary")
With Me.TreeView1
.Nodes.Clear
.LineStyle = tvwRootLines
'Hauptknoten
Set ndeMain = .Nodes.Add(, , Key:=Replace(wkb.Name, " ", "_", 1, -1, vbTextCompare), _
Text:=wkb.Name)
'ndeMain.Tag = wkb.Name & "~" & wkb.Worksheets(1).Name & "~" & wkb.Worksheets(1).Cells( _
1, 1).Address
With wks
'letzte beschriebene Zeile in Tabelle 'Autos' & Spalte 'A'
nAnzahl1 = wks.Cells(.Rows.Count, 1).End(xlUp).Row
nAnzahlS1 = wks.Cells(3, 256).End(xlToLeft).Column
MsgBox nAnzahlS1
End With
'ab Zeile '3'
For nAnzahl2 = 3 To nAnzahl1
'Spalte 'A'
sWert1 = wks.Cells(nAnzahl2, 1).Value
If sWert1 = "" Then GoTo Ende
'Key-Werte im Treeview dürfen kein Leerzeichen enthalten
sWert2 = Replace(sWert1, " ", "_", 1, -1, vbTextCompare)
swert3 = sWert2
If Not dic1.exists(sWert2) Then
dic1.Add sWert2, sWert1
Set ndeMain1 = .Nodes.Add(ndeMain.Key, 4, Key:=sWert2, Text:=sWert1)
Else
Set ndeMain1 = .Nodes(sWert2)
End If
ndeMain1.Sorted = True
h = 0
' Spalte B bis letzte benutzte -1
For h = 2 To nAnzahlS1 - 1
sWert1 = wks.Cells(nAnzahl2, h).Value
If sWert1 = "" Then GoTo Ende
'Key-Werte im Treeview dürfen kein Leerzeichen enthalten
sWert2 = Replace(sWert1, " ", "_", 1, -1, vbTextCompare)
If Not dic2.exists(swert3 & "~" & sWert2) Then
dic2.Add swert3 & "~" & sWert2, sWert1
Set ndeMain1 = .Nodes.Add(ndeMain1.Key, 4, Key:=swert3 & "~" & sWert2, Text:= _
sWert1)
Else
Set ndeMain1 = .Nodes(swert3 & "~" & sWert2)
End If
ndeMain1.Sorted = True
Next h
'Spalte 'F'
sWert1 = wks.Cells(nAnzahl2, nAnzahlS1).Value
'fehlende Angaben iin der Spalte 'D' nicht verwerten
If Trim(sWert1) "" Then
'Key-Werte im Treeview dürfen kein Leerzeichen enthalten
swert3 = Replace(sWert1, " ", "_", 1, -1, vbTextCompare)
iCounter = iCounter + 1
Set ndeMain1 = .Nodes.Add(ndeMain1.Key, 4, Key:=sWert2 & "~" & iCounter, Text:= _
sWert1)
ndeMain1.Sorted = True
End If
Ende:
Next nAnzahl2
ndeMain.Expanded = True
ndeMain.Sorted = True
End With
Set ndeMain = Nothing: Set ndeMain1 = Nothing
Set wks = Nothing
Set wkb = Nothing
End Sub
Sub test()
Dim aDic() As Object
Dim i&, k&, wert
ReDim aDic(1 To 4)
For i = 1 To 4
Set aDic(i) = CreateObject("scripting.dictionary")
For k = 1 To 5
aDic(i)("Dic Nr. " & i & ": " & k) = "Bla" & k
Next
k = 1
For Each wert In aDic(i).keys
Cells(k, i) = wert & ": " & aDic(i)(wert)
k = k + 1
Next
Next
' hier weitere Aktionen, dann
For i = 1 To 4
Set aDic(i) = Nothing
Next
End Sub
Schöne Grüße,
Private Sub Userform_initialize()
Dim wkb As Workbook, wks As Worksheet
Dim ndeMain As MSComctlLib.Node, ndeMain1 As MSComctlLib.Node
Dim i&, SpB$(1 To 20) ' &=as long; SpaltenBuchstabe $=as string
Dim vZ&, bZ&, z& ' vZ=von Zeile, bZ=bis Zeile, z=Zeilenzähler
Dim vS&, bS&, s& ' vS, bS, s = von/Spalte, s=Zähler
Dim dic As Object, a ' Variant, a wie "alles" als Array
' Dim sW ' Variant, wie "stringWert" als Array
Dim sWert1 As String, sWert2 As String, swert3 As String
'Spaltenbuchstaben bis max. 20 Spalten; geht immer, auch ab "AA"
For i = 1 To 20: SpB(i) = Split(Columns(i).Address(0, 0), ":")(0): Next
vZ = 3
Set wkb = ThisWorkbook
Set wks = wkb.Worksheets("Autos")
a = wks.Range("A" & vZ).CurrentRegion
vZ = LBound(a): bZ = UBound(a): vS = LBound(a, 2): bS = UBound(a, 2)
' sW = wks.Range("A1").Resize(1, vS)
Set dic = CreateObject("Scripting.Dictionary")
With Me.TreeView1
.Nodes.Clear
.LineStyle = tvwRootLines
'Hauptknoten
Set ndeMain = .Nodes.Add(, , Key:=Replace(wkb.Name, " ", _
"_", 1, -1, vbTextCompare), Text:=wkb.Name)
For z = vZ To bZ
' Die ERSTE Spalte erhält anscheinend eine Sonderbehandlung...
sWert2 = Replace(a(z, vS), " ", "_", 1, -1, vbTextCompare)
swert3 = sWert2
If Not dic.exists(SpB(vS) & sWert2) Then
dic.Add SpB(vS) & sWert2, a(z, vS)
Set ndeMain1 = .Nodes.Add(ndeMain.Key, 4, Key:=sWert2, Text:=a(z, vS))
Else
Set ndeMain1 = .Nodes(sWert2)
End If
ndeMain1.Sorted = True
' Die 2. bis vorletzte sind identisch?!
' nach Bedarf evtl. String-Array verwenden und _
' Einzelteil mit JOIN zusammensetzen?
For s = vS + 1 To bS - 1
sWert1 = a(z, s)
'Key-Werte im Treeview dürfen kein Leerzeichen enthalten
sWert2 = Replace(sWert1, " ", "_", 1, -1, vbTextCompare)
If Not dic.exists(SpB(s) & swert3 & "~" & sWert2) Then
dic.Add SpB(s) & swert3 & "~" & sWert2, sWert1
Set ndeMain1 = .Nodes.Add(ndeMain1.Key, 4, Key:=swert3 & _
"~" & sWert2, Text:=sWert1)
Else
Set ndeMain1 = .Nodes(swert3 & "~" & sWert2)
End If
ndeMain1.Sorted = True
Next
' und die LETZE bekommt auch eine Sonderbehandlung
sWert1 = a(z, bS)
'fehlende Angaben iin der Spalte 'D' nicht verwerten
If Trim(sWert1) "" Then
'Key-Werte im Treeview dürfen kein Leerzeichen enthalten
swert3 = Replace(sWert1, " ", "_", 1, -1, vbTextCompare)
i = i + 1
Set ndeMain1 = .Nodes.Add(ndeMain1.Key, 4, Key:=sWert2 & _
"~" & i, Text:=sWert1)
ndeMain1.Sorted = True
End If
Next
ndeMain.Expanded = True
ndeMain.Sorted = True
End With
Set ndeMain = Nothing: Set ndeMain1 = Nothing
Set wks = Nothing
Set wkb = Nothing
End Sub