• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Het drama dat "Dictionary" heet [VBA]

Status
Niet open voor verdere reacties.
Ginger

Ginger

Terugkerende gebruiker
Lid geworden
29 dec 2006
Berichten
2.972
De "oude bekenden" van mij weten hoe ik altijd loop te klooien met Collections en wat ik naar goed voorbeeld ZOU moeten gebruiken "de Dictionary's". Ik ben nu bezig met een procedure waarmee ik snel uit een grote tabel de unieke Key's kan overhouden met de daarbij behorende Items en het totaal van de gelijke Key's.
In de bijlage zie je een Workbook met 2 sheets. In de sheet "Input van VPIG" staat een heel klein deeltje van een tabel van bijna 65.000 records die ik werkelijk moet "verdichten". De tabel bevat 3 velden: AFNE, ARTI, AANT. Aan de hand van het samenvoegen van het veld AFNE en ARTI krijg je een unieke sleutel voor een record (dus per artikel per winkel). Een winkel kan een artikel in 1, 2 of 3 weken ontvangen. Ik wil dus weten wat het totaal per winkel per artikel is.
Uiteraard kan dit via een Pivot Table, maar de 2007 versie gaat hier nog niet lekker mee om omdat de velden AFNE en ARTI niet worden herhaald, en dat heb ik nou net wél nodig.

Op de sheet "Output Voor Analyse" heb ik nu de gewenste output handmatig aangemaakt. Maar zo zou het er moeten uitzien als mijn niet werkende VBA procedure gewerkt zou hebben... :o

Wie kan en wil mij hiermee helpen om een juiste Dictionary procedure te maken?
 

Bijlagen

Is dit wat ?

Code: 
Sub M_snb()
  sn = Sheets(1).Cells(1).CurrentRegion

  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      c00 = sn(j, 1) & "_" & sn(j, 2)
      .Item(c00) = .Item(c00) + sn(j, 3)
    Next

    Sheets(2).Cells(1).Resize(.Count, 2) = Application.Transpose(Array(.keys, .items))
  End With
End Sub

NB. Transpose heeft zijn beperkingen met grotere aantallen.

Het draaitabelprobleem ontgaat me:
 

Bijlagen

Laatst bewerkt:
snb zei:
NB. Transpose heeft zijn beperkingen met grotere aantallen.
Klik om te vergroten...

Snb, dank voor je VBA oplossing. Ik moet 'm nog uitproberen op m'n werk met de "echte" tabel van meer dan 65.000 records. Om jouw "NB" te omzeilen heb ik deze oplossing bedacht...
Code: 
Sub Verdichten()

    sn = Sheets(1).Cells(1).CurrentRegion
    With CreateObject("scripting.dictionary")
       For j = 2 To UBound(sn)
          c00 = CStr(sn(j, 1) & ", " & sn(j, 2) & ", " & sn(j, 1) & sn(j, 2))
          .Item(c00) = .Item(c00) + sn(j, 3)
       Next
       ReDim Resultaat(0 To .Count, 1 To 1)
       For j = 0 To .Count - 1
            Resultaat(j, 1) = .Keys()(j) & ", " & .Items()(j)
       Next j
       With Sheets(2).Cells(2, 1).Resize(.Count, 1)
            .Value = Resultaat
            .TextToColumns
       End With
     End With

End Sub
Ofwel, er wordt van de Dictionary gebruik gemaakt om snel de gelijke regels te kunnen optellen maar daarna wordt de boel overgepompt in een array die de beperking van het tranpose niet kent. Ga je hierin mee?


snb zei:
Het draaitabelprobleem ontgaat me:
Klik om te vergroten...
...en...
E v R zei:
als reaktie op jouw Pivot opmerking; dit kan toch gewoon?(tenminste als ik je goed begrijp)
Klik om te vergroten...
EvR, uiteraard ook jij weer bedankt voor het meedenken en aandragen van een oplossing. Helaas werken wij op kantoor nog met Office 2007 en die kent nog niet de optie om gelijke velden wél te tonen. Deze optie is ingebouwd vanaf versie 2010.
Daarnaast is het nodig voor de verdere verwerking dat m'n output zou zijn zoals ik die in het voorbeeld in de tweede sheet had geplaatst.

Voor nu ben ik dus uitstekend geholpen en zal jullie morgen nog laten weten hoe de performance is op die grote productie tabel...

[EDIT] En o ja... voor ik het vergeet... Een draaitabel op meer dan 65000 records vond mijn versie van Excel óók niet echt leuk. ;)
 
Laatst bewerkt:
Vanochtend op kantoor gelijk een test gedaan met 61.983 records. Tot m'n grote verdriet duurde het proces erg lang en schoot Excel op een gegeven moment op "not responding". Zelfs Ctrl + Break wilde niet helpen. Toen ik Excel via de Taskmanager stopte, ging VBA vreemd genoeg - gelukkig - wél in Break Mode. Het trage deel was dus vooral NIET het Dict gedeelte, maar het overzetten van dict naar array. Hierop ben ik er wat mee gaan stoeien en heb een "stop" ingelast als de teller op 5000 zou komen (If j = 5000 Then Stop). De eerste keer verliep dit nog razendsnel, maar richting de 10.000 schoot Excel op "not responding". De truuk via de Taskmanager werkte weer en de teller stond op 10.000.
Omdat de totale output de 65.000 records niet overschreed, besloot ik maar om de Transpose regel in te zetten van snb (ipv mijn omzetting naar Array). In een split second had ik m'n output op de tweede sheet....

Deze procedure kan dus goed gebruikt worden totdat het aantal output-records de 65.000 heeft bereikt. Maarrrr... vraag ik me tóch af waarom de procedure vastloopt op het overzetten van de gegevens van de dict naar de array? Is het opzoeken van een key van deze lengte en opbouw ("5003, 383627, 5003383627") soms een moeizame klus?
 
@Ginger

Hoe laat wordt die doos Pomerol (Barrolo mag ook) bezorgd ? :d

waarom gebruik je zo'n dubbel uitgevoerde key ?
Cstr is overbodig als je in een koppeling een komma en spatie zet.

ik denk dat je met de key de dictionary sneller doorloopt.

Code: 
Sub M_snb()
  sn = Sheets(1).Cells(1).CurrentRegion
    
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      c00 = sn(j, 1) & "_" & sn(j, 2)
      .Item(c00) = .Item(c00) + sn(j, 3)
    Next
       
    For Each it In .keys
      .Item(it) = it & "_" & Replace(it, "_", "") & "_" & .Item(it)
    Next
       
    Sheets(2).Cells(1).Resize(.Count) = Application.Transpose(.items)
  End With
     
  Sheets(2).Cells(1).CurrentRegion.Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, "_"
End Sub

een andere manier om transpose te vermijden:
Code: 
Sub M_snb()
  sn = Sheets(1).Cells(1).CurrentRegion
    
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      c00 = sn(j, 1) & "_" & sn(j, 2)
      .Item(c00) = .Item(c00) + sn(j, 3)
    Next
       
    For Each it In .keys
      .Item(it) = it & "_" & Replace(it, "_", "") & "_" & .Item(it)
    Next
    sn = .items
  End With       
  
  With CreateObject("New:{8BD21D20-EC42-11CE-9E0D-00AA006002F3}")
    .List = sn
    Sheets(2).Cells(1).Resize(ubound(sn)+1) = .List
  End With
     
  Sheets(2).Cells(1).CurrentRegion.Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, "_"
End Sub
 
Laatst bewerkt:
snb, werkelijk waar wéér magnifiek!!!! :thumb:

Dacht ik dus enigszins iets te snappen van de Dictionary (met op de achtergrond jouw snb-vba.eu pagina), haal je dat weer volledig onderuit door nu met .keys te gaan werken. Ik zie nu óók dat jij rechtstreeks een Dictionary "leegt" in een array. Ik had ergens gelezen dat dit dus niet kon. Vandaar mijn lus om het zo over te zetten...

En je vraag "waarom gebruik je zo'n dubbel uitgevoerd key" komt door het feit dat ik graag uiteindelijk m'n 4 kolommen wilde hebben en géén andere mogelijkheid zag. Wat jij nu weer doet ziet er erg logisch uit, maar is wel het resultaat van een zéér goed programmeur. Iets waar ik nog niet ook nog maar een béétje aan kan tippen.... :o

Afijn, weer een hoop stof om te bestuderen, maar voor nu heb ik een grandioos snelle oplossing voor m'n probleem. Weer dank voor je hulp.

En voor wat betreft het wijntje? Stuur me maar ff privé een mailtje met je adres. Regel ik iets voor je.
 
@snb :thumb:
Ik was zelf ook al bezig met die transpose (ook uit jouw niet afgesloten draadje @Ginger ;) ), maar 2 keer knipperen met de ogen en snb heeft al een werkende code geplaatst :thumb:

@Ginger je moet echt jouw baas gaan vragen om Excel2016 met PowerQuery... volgens mij kun je al jouw database-array-dictionary vraagstukken daarin oplossen :d

Overigens een testje met PowerQuery versus de snb methode van hierboven op 85K rijen: PQ 1.35s snb 1,07s :D
 
@E v R

Gebaseerd op jouw suggestie elders.... :thumb:
Die vergelijking met PowerQuery: heel aardig & informatief.
Wellicht doet Powerquery op de achtergrond iets soortgelijks als wat ik in VBA doe: dictionaries/arrays.

@Ginger

Komt voor de bakker.
 
E v R zei:
ook uit jouw niet afgesloten draadje @Ginger ;)
Klik om te vergroten...
Whoopssssss.... Bij deze rechtgezet. Dank voor het wijzen op dit feit.

@Erik, Vragen om Office2016? Ik ben écht al héél blij als we op een gegeven moment overstappen naar een nieuwe(re) versie van MS Office. Men neigt namelijk steeds meer naar Docs, Sheets en Slides van Google. Iets waar ik persoonlijk niet heel gelukkig van zou worden. ;)\
Ook dank voor je vergelijkend onderzoek in beide procedures. Hou ik voor nu toch echt bij die van snb (en een stukje van jou).
 
Zou dit niet ook met ADO kunnen (voor degenen die moeite hebben met Dictionaries ;) )

Dit krijg ik voor elkaar:

Code: 
Sub M_snb()
  With CreateObject("ADODB.recordset")
    .Open "SELECT afne, arti ,afne & arti , aant FROM `Input_van_VPIG$`", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 8.0"""
    Sheets("output_voor_analyse").Cells(1, 10).CopyFromRecordset .DataSource
  End With
end sub

Maar nu de sommatie van aantal per afne/arti combinatie:

Ik dacht aan
Code: 
Sub M_snb()
  With CreateObject("ADODB.recordset")
    .Open "SELECT afne, arti ,afne & arti , aant FROM `Input_van_VPIG$` GROUP BY afne & arti", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 8.0"""
    Sheets("output_voor_analyse").Cells(1, 10).CopyFromRecordset .DataSource
  End With
End Sub

Maar daarmee ga ik de mist in.
 
Code: 
With CreateObject("ADODB.recordset")
    .Open "SELECT afne, arti ,afne & arti , [COLOR="#FF0000"]SUM[/COLOR](aant)  FROM `Input_van_VPIG$` GROUP BY [COLOR="#FF0000"]afne, arti ,[/COLOR]afne & arti ", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 8.0"""
    Sheets("output_voor_analyse").Cells(1, 10).CopyFromRecordset .DataSource
  End With
 
Laatst bewerkt:
Kijk, zo leer je nog eens wat.
Dankjewel E v R.

Ik heb niet de indruk dat deze code erg langzaam is.
Kun jij de snelheidsvergelijking met Powerquery en de Dictionary maken ?
 
Inderdaad erg snel:
Op een tabel met 500K rijen waarvan 499215 unieke combinaties:
ADODB 3,886719
PowerQ 41,53125
Script 104,4414
Klik om te vergroten...

@Ginger, kun jij op jouw 'echte' data de code uit post #12 loslaten?
 
Nu we toch zo gezellig bezig zijn:

Code: 
Sub M_snb_DAO()
  Sheets("output_voor_analyse").Cells(1, 10).CopyFromRecordset CreateObject("DAO.DBEngine.120").OpenDatabase(ThisWorkbook.FullName, False, True, "Excel 8.0;HDR=Yes").openrecordset("SELECT afne, arti ,afne & arti , sum(aant)   FROM [Input_van_VPIG$] GROUP BY afne, arti, afne & arti ").openrecordset
End Sub
 
met 85K rijen en 84215 unieke combinaties:

Script 7,753906
PowerQ 7,378906
DAO 7,417969
ADODB 1,578125
Klik om te vergroten...

overigens de 2e code uit post#6 heeft vanwege de Lbound van de Listbox een +1 nodig:
Code: 
Sheets(2).Cells(1).Resize(ubound(sn)[COLOR="#FF0000"]+1[/COLOR]) = .List
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan