Een array in een dictionary manipuleren. En de datums correct weer laten geven

[VenA]

Beste helpers,

Hoewel ik steeds meer begin te begrijpen van een dictionary toch een paar vragen:

In dit draadje https://www.helpmij.nl/forum/showthread.php/941215-dubbele-data-optellen?p=6135998#post6135998 heb ik weliswaar een werkende oplossing geplaatst maar volgens mij moet de code eenvoudiger kunnen. Waar ik tegenaan loop is dat ik niet direct de array die gekoppeld is aan de key kan manipuleren. Wel opvragen maar de waarde wijzigen lukt niet.

d.Item(c00)(3) = d.Item(c00)(3) + 1

Door het gebruik van een variabele lukt dit wel maar lijkt mij omslachtig? Maak ik hier een denkfout of kan het niet anders?

De uiteindelijke gegevens wil ik wegschrijven dmv

Sheets("Blad2").Cells(1).Resize(d.Count, UBound(ar, 2)) = Application.Index(d.items, 0, 0)

maar dan krijg ik de Amerikaanse datumnotatie. Met een extra variabele en een lusje lukt het wel maar kan dit niet eenvoudiger?

Werkt wel maar omslachtig denk ik:

Sub VenA()  ar = Sheets("Export TT").Cells(1).CurrentRegion
  Set d = CreateObject("Scripting.dictionary")
  For j = 1 To UBound(ar)
    c00 = ar(j, 5) & ar(j, 6) & ar(j, 7) & ar(j, 8)
    If d.Exists(c00) Then
      ar1 = d.Item(c00)
      ar1(3) = ar1(3) + 1
      d.Item(c00) = ar1
     Else
      d.Item(c00) = Application.Index(ar, j, 0)
    End If
  Next j
  ar2 = Application.Index(d.items, 0, 0)
  For j = 2 To UBound(ar2)
    ar2(j, 7) = CDate(ar2(j, 7))
    ar2(j, 9) = CDate(ar2(j, 9))
  Next j
  Sheets("Blad2").Cells(1).Resize(d.Count, UBound(ar, 2)) = ar2
End Sub

Werkt (nog)niet:

Sub VenA_test()ar = Sheets("Export TT").Cells(1).CurrentRegion
  Set d = CreateObject("Scripting.dictionary")
  For j = 1 To UBound(ar)
    c00 = ar(j, 5) & ar(j, 6) & ar(j, 7) & ar(j, 8)
    If d.Exists(c00) Then
      Debug.Print d.Item(c00)(3)
      d.Item(c00)(3) = d.Item(c00)(3) + 1
      Debug.Print d.Item(c00)(3)
     Else
      d.Item(c00) = Application.Index(ar, j, 0)
      'Debug.Print d.Item(c00)(3)
    End If
  Next j
  Sheets("Blad2").Cells(1).Resize(d.Count, UBound(ar, 2)) = Application.Index(d.items, 0, 0)
End Sub

 

[HSV]

@snb kon het ook al niet.

I couldn't find a method to adapt an element in an array of a Dictionary Item directly.
Although the following code doesn't error out, the 4th element in the array isn't been changed by the line .Item("aa")(3) = "the fourth item is " & .Item("aa")(3).

With CreateObject("scripting.dictionary")
.Item("aa") = Array("zz1", "zz2", "zz3", "zz4")
MsgBox .Item("aa")(3)

.Item("aa")(3) = "the fourth item is " & .Item("aa")(3)
MsgBox .Item("aa")(3)
End With

 

[VenA]

Bedankt voor je antwoord. Het hoofdstuk 'Dictionaries' heb ik de laatste tijd regelmatig doorgenomen maar blijkbaar gemist dat het niet in 1 keer kan. Wel blij dat ik toch een werkende oplossing gevonden heb die hetzelfde is als die van @snb. Toch weer wat geleerd.:d

 

[HSV]

Wat ook weer interessant is dat je .item kunt laten vervallen.

If d.Exists(c00) Then
      ar1 = d(c00)
      ar1(3) = ar1(3) + 1
      d(c00) = ar1
     Else
      d(c00) = Application.Index(ar, j, 0)

 

[VenA]

Svp niet eenvoudiger maken dan het al is.

 

[snb]

interessant is dat je .item kunt laten vervallen. En meer

If d.Exists(c00) Then
      ar1 = d(c00)
      ar1(3) = ar1(3) + 1
      d(c00) = ar1
     Else
      d(c00) = Application.Index(ar, j)

 

[snb]

interessant is dat je .item kunt laten vervallen. En meer

If d.Exists(c00) Then
      ar1 = d(c00)
      ar1(3) = ar1(3) + 1
      d(c00) = ar1
     Else
      d(c00) = Application.Index(ar, j)

 

[HSV]

Ik heb vroeger al geleerd dat nul niets is.

 

[VenA]

Moet je wel het goede voorbeeld geven:d

23.1 Delete duplicate rows/arrays

Column A contains the record keys, some of which are duplicates.
Columns B:F etc, contain the data of the records.
Sub M_delete_duplicates()
sn = Sheets("Sheet1").Cells(1).CurrentRegion.resize(,5)

With CreateObject("scripting.dictionary")
For j = 1 To UBound(sn)
.Item(sn(j, 1)) = Application.Index(sn, j, 0)
Next

 

[HSV]

Werkt prima zonder de komma 0.

 

[E v R]

Als je ipv een Array een Object gebruikt (en dus een referentie) kan het wel.

Nu wordt er op snb's site ook een ArrayList uitvoerig beschreven:

Sub nn()
Set x = CreateObject("scripting.dictionary")
Set y = CreateObject("System.Collections.ArrayList")

With y
    For Each it In Array("zz1", "zz2", "zz3", "zz4")
        .Add it
    Next
End With

With x
    Set .Item("aa") = y
    MsgBox .Item("aa")(3)
    .Item("aa")(3) = "the fourth item is " & .Item("aa")(3)
    MsgBox .Item("aa")(3)
End With

End Sub

 

[snb]

@EvR

Prima :thumb:

Twee dictionaries kunnen dan ook:

Sub M_snb()
  Set x = CreateObject("scripting.dictionary")
  Set y = CreateObject("scripting.dictionary")
    
  For Each it In Array("zz1", "zz2", "zz3", "zz4")
    y.Item(y.Count) = it
  Next
   
  Set x.Item("aa") = y
  MsgBox x.Item("aa")(3)
    
  x.Item("aa")(3) = "the fourth item is " & x.Item("aa")(3)
  MsgBox x.Item("aa")(3)
End Sub

 

[HSV]

Ik had al eerder op de avond een reactie geplaatst met een voorbeeld.
Helaas klopte er niets van en kan het ook niet meer nabootsen toen het wel klopte.

Maakt niet uit.

Nog een manier wat op hetzelfde neerkomt.

Sub hsv()
Set x = CreateObject("scripting.dictionary")
  x.Item("aa") = Array(Array("zz1", "zz2", "zz3", "zz4"), CreateObject("scripting.dictionary"))
  x.Item("aa")(1)(3) = x.Item("aa")(0)(3)
   
    MsgBox x.Item("aa")(1)(3)
    MsgBox x.Item("aa")(0)(3)
    
    x.Item("aa")(1)(3) = "the fourth item is " & x.Item("aa")(1)(3)


    MsgBox x.Item("aa")(1)(3)
End Sub