Lijst creëren per Dict.item

[JEC.]

Beste helpers,

Ik heb een groot(matrix formules te traag) databestand waarbij ik een lijst moet creëren met unieke waarden.
Het lukt me voor me gevoel aardig om de gewenste gegevens te verkrijgen met VBA, maar de vraag is of ik zonder de tweede For-loop(dus zonder de split etc..) de gegevens in 1 klap, onder elkaar kan krijgen.

Sub j()
Dim i, ii As Integer
jv = Cells(1, 1).CurrentRegion
With CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(jv)
   .Item(jv(i, 1)) = .Item(jv(i, 1)) & jv(i, 2) & "|"
  Next i
    Cells(1, 6).Resize(2, .Count) = Application.Index(Array(.keys, .items), 0, 0)
  For ii = 6 To .Count + 5
    x = Split(Cells(2, ii), "|")
    Cells(2, ii).Resize(UBound(x)) = Application.Transpose(x)
  Next ii
End With
End Sub

Bedankt Alvast!

 

[cow18]

gegevens staan wel 90 graden gedraaid.
Transpose werkt maar goed tot een grote 30.000, vanaf daar is het link.
Hoe groot is je "grote" database ?

Sub j()
   Dim i, ii   As Integer, leeg(1 To 1000)       'leeg ruim groot genoeg pakken

   Set dict = CreateObject("Scripting.Dictionary")
   With dict
      jv = Cells(1, 1).CurrentRegion             'gegevens

      For i = 1 To UBound(jv)                    '1 na 1 aflopen
         If Not .exists(jv(i, 1)) Then .Add jv(i, 1), leeg   ' bestaat nog niet, dus toevoegen met leeg
         arr = dict(jv(i, 1))                    'vorige gegevens terughalen
         If arr(1) < UBound(arr) Then            'aantal opgeslagen gegevens kleiner dan voorziene limiet ?
            arr(1) = Application.Max(3, arr(1) + 1)   'pointer ophogen
         Else
            MsgBox "voor " & jv(i, 1) & " is de voorziene ruimte te klein" & vbLf & "verlies aan data ", vbCritical   'foutmelding
         End If
         arr(2) = jv(i, 1)                       'naam
         arr(arr(1)) = jv(i, 2)                  'waarde
         dict(jv(i, 1)) = arr                    'terugschrijven naar dictionary
      Next i
      arr = Application.Index(dict.items, 0, 0)  'items van dictionary uitlezen

      With Cells(2, 6)                           'naar hier wegschrijven
         .CurrentRegion.ClearContents            'vorige gegevens wissen
         .Resize(dict.Count, Application.Max(Application.Index(arr, 0, 1))) = arr   ' wegschrijven (bepaal max aantal kolommen
      End With
   End With
End Sub

 

[snb]

Warom geen draaitabel ?

 

[cow18]

kleine variant

Sub j()
   Dim i, ii   As Integer, leeg(1 To 1000)       'leeg ruim groot genoeg pakken

   Set dict = CreateObject("Scripting.Dictionary")
   With dict
      jv = Cells(1, 1).CurrentRegion             'gegevens
      s = ""
      For i = 1 To UBound(jv)                    '1 na 1 aflopen
         If .exists(jv(i, 1)) Then
            arr = dict(jv(i, 1))                 'vorige gegevens terughalen
         Else
            arr = leeg                           'start met leeg
            arr(2) = jv(i, 1)                    'naam
         End If
         arr(1) = Application.Min(UBound(arr), Application.Max(3, arr(1) + 1))   'pointer ophogen met min=3 en max=ubound van leeg
         If arr(1) = UBound(arr) And s = "" Then s = jv(i, 1)
         arr(arr(1)) = jv(i, 2)                  'waarde
         dict(jv(i, 1)) = arr                    'terugschrijven naar dictionary
      Next i
      arr = Application.Index(dict.items, 0, 0)  'items van dictionary uitlezen
      If Len(s) Then MsgBox "De voorziene ruimte is te klein in leeg, verlies aan data voor minstens 1 persoon" & vbLf & s, vbCritical   'foutmelding

      With Cells(2, 6)                           'naar hier wegschrijven
         .CurrentRegion.ClearContents            'vorige gegevens wissen
         .Resize(dict.Count, Application.Max(Application.Index(arr, 0, 1))) = arr   ' wegschrijven (bepaal max aantal kolommen
      End With
   End With
End Sub

 

[JEC.]

Bedankt voor de reacties. Ik kan er morgen naar kijken. De draaitabel is een optie maar in dit geval niet.

 

[JEC.]

De twee macro's geven zoals je zei 90 graden gedraaide output. De gegevens dienen echter onder elkaar te komen, net als in het voorbeeldbestand.
Ik sta open voor andere suggesties!

In ieder geval bedankt voor de tijd en moeite:thumb:

 

[cow18]

met de opmerking van in #2, dat geen enkele dimensie boven de 30.000 mag gaan.

With Cells(2, 6)                           'naar hier wegschrijven
         .CurrentRegion.ClearContents            'vorige gegevens wissen
   [COLOR="#FF0000"]      .Resize(Application.Max(Application.Index(arr, 0, 1)), dict.Count) = [SIZE=4]Application.Transpose[/SIZE](arr)  ' wegschrijven (bepaal max aantal kolommen
 [/COLOR]     End With

Als je dan nog die 1e rij met pointers niet wilde zien, tja, die kon ook als allerlaatste item in de array gebruikt zijn en niet meegekopieerd worden naar het tabblad.
Kleine wijziging, kan je vermoedelijk ook zelf bedenken, anders vanavond.
Bovendien vind ik de tijd die de macro er over doet, buiten proportie.

 

[JEC.]

De pointers mogen erboven staan. Helemaal prima.
Ik probeer tevens de dictionary beter te begrijpen. Ik zal de vraag op opgelost zetten

Bedankt voor hulp!

 

[cow18]

https://excelmacromastery.com/vba-dictionary/
http://www.snb-vba.eu/VBA_Dictionary.html

 

[JEC.]

Die had ik inderdaad gevonden en al bestudeerd. Daarmee kreeg ik het voor elkaar om mijn macro werkend te krijgen. Toch blijf ik een dictionary (nog)moeilijk begrijpbaar vinden.

 

[cow18]

misschien oogt dit wat eenvoudiger
Let wel, 2e loop is niet weg zoals gewenst

 

[JEC.]

@Cow, bedankt voor de input. Iets moois om op te studeren:thumb: En inderdaad, je laatste voorbeeld begrijp ik beter dan de vorige(die lijkt op die van mij)

 

[snb]

Om je een beeld te geven:

1. Gebruik voor Macro's altijd een naam die niet met een ander object in VBA verward kan worden. (bijv M_....
2. geef kolommeen altijd een naam; dat breidt het aantal gebruiksmogelijkheden enorm uit (bijv. advancedfilter, sortern, draaitabellen, etc.)
3. in dit geval heb je geen dictionary nodig om het resultaat te krijgen, maar voor illustratie van de dictionary toch toegepast.
4. de code illustreert, dat een dictionary 2-dimensionele arrays kan bevatten
5. Omdat we hier te maken hebben met 2-dimentsionele Arrays' kunnen we geen gebruik maken van Application.index of application transpose om alle items van de dictionary in één keer naar het werkblad te schrijven.

Dit is de code:

Sub M_snb()
  sn = Cells(1).CurrentRegion
  Cells(1).CurrentRegion.Columns(1).AdvancedFilter 2, , Cells(1, 20), True
    
  With CreateObject("scripting.dictionary")
    For j = 2 To Columns(20).SpecialCells(2).Count
      Cells(1).CurrentRegion.AdvancedFilter 2, Cells(1, 20).Resize(2), Cells(10, 6)
      Cells(10, 7) = Cells(2, 20)
      .Item(Cells(2, 20).Value) = Cells(10, 6).CurrentRegion.Columns(2).Value
      Cells(10, 6).CurrentRegion.ClearContents
      Cells(2, 20) = Cells(j + 1, 20)
    Next
         
    For Each it In .Keys
      Cells(20, 6 + y).Resize(UBound(.Item(it))) = .Item(it)
      y = y + 1
    Next
  End With
End Sub

Een puur VBA-alternatief met slecht 1 lus:

Sub M_snb()
    sn = Cells(1).CurrentRegion
    ReDim sp(100)
    
    With CreateObject("scripting.dictionary")
        For j = 2 To UBound(sn)
           st = .Item(sn(j, 1))
           If IsEmpty(st) Then st = sp
           st(0) = sn(j, 1)
           st(100) = st(100) + 1
           st(st(100)) = sn(j, 2)
           .Item(sn(j, 1)) = st
        Next
        
        Cells(11, 6).Resize(100, .Count) = Application.Transpose(.items)
    End With
End Sub

 

[HSV]

Ook een duit in het zakje.

Sub hsv()
Dim jv, sv, a, i As Long, d As Object
jv = Cells(1, 1).CurrentRegion
ReDim b(UBound(jv))
Set d = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(jv)
   a = d.Item(jv(i, 1))
     If IsEmpty(a) Then a = b
      a(0) = jv(i, 1)
      d.Item(jv(i, 1)) = a
      a(UBound(jv) - UBound(Split(Join(Filter(d.Item(jv(i, 1)), "|", False), " |"), "| "))) = jv(i, 2)
      d.Item(jv(i, 1)) = a
  Next i
  With Cells(1, 6)
  sv = Application.Transpose(Application.Index(d.Items, 0, 0))
   .CurrentRegion.ClearContents
   .Resize(UBound(sv), UBound(sv, 2)) = sv
  End With
End Sub

 

[JEC.]

Snb en Harry, bedankt voor de hulp en uitleg! Ik ga hier volgende week eens goed naar kijken. Er valt nog veel te leren

 

[HSV]

@snb, heb ik je op een idee gebracht met maar een lus?

Je tweede (aangepaste) code heb je overigens mooi uitgewerkt.
Om de code variabel te maken.

Sub hsv()
sv = Cells(1).CurrentRegion
 ReDim b(UBound(sv) + 1)
  With CreateObject("scripting.dictionary")
        For j = 1 To UBound(sv)
            a = .Item(sv(j, 1))
              If IsEmpty(a) Then a = b
                 a(0) = sv(j, 1)
                 a(UBound(a)) = a(UBound(a)) + 1
                 a(a(UBound(a))) = sv(j, 2)
                 .Item(sv(j, 1)) = a
        Next
    Cells(1, 6).Resize(UBound(a) - 1, .Count) = Application.Transpose(.items)
  End With
End Sub

Punt 5 kan nu verwijderd worden uit je laatste schrijven?

 

[JEC.]

Ik vind het maar knap hoe jullie het allemaal bedenken:thumb: Ik kan het lezen maar zelf kom ik er niet op

 

[snb]

@HSV

Jammer, maar het idee bestond al voor ik jouw bijdrage gelezen had ...
Punt 5 blijft van toepassing op meer-dimensionele en 'jagged' ( = in omvang ongelijke) Arrays.

Over snelheid heb ik in ieder geval niet te klagen.

 

[HSV]

Ideeën genoeg, maar nog nooit uitgevoerd in het verleden.