Het drama dat "Dictionary" heet [VBA]

[jkpieterse]

@EvR: Kan je mijn methode ook eens timen (heeft geen zin als ik het doe, kan je niet vergelijken als het niet dezelfde machine e.d. was)?

 

[E v R]

Nog even een timing op de JKP_Pivot: 53,9106 bij 85K rijen, bij 500K heb ik na 10 min de boel maar afgebroken. Bij kleinere aantallen worden de verschillen uiteraard kleiner (Overigens zie ik een pivot meer om data samen te vatten en niet om er weer een reuzachtige tabel van te maken)

@snb, qua lezen geef ik je volkomen gelijk, maar met die +1 wordt wel de hele List geplaatst anders mis je het laatste item.


Leuk draadje! :d

 

[snb]

@E v R

De stelling klopt, :thumb:de redenering niet.
sn is nl. het equivalent van de eigenschap .items van de Dictionary.
Ook dat is een array met lbound 0.
Het heeft dus niet met de listbox te maken, maar met de dictionary.
Ik zal het fluks aanpassen.

 

[snb]

@Jkp

Listig :thumb:

Zonder die variable oPT loopt ie ook best lekker

Vreemd dat de schoonmaak van het resultatenblad ook blijkbaar het klembord leegveegt.
Wellicht zo nog iets sneller:

Sub DoItMyWay()
    Application.ScreenUpdating = False
    
    With ThisWorkbook.Sheets("Eindresultaat")
        .UsedRange.Clear
        
        With ThisWorkbook.Sheets("Draaitabel").PivotTables(1)
            .RefreshTable
            .TableRange2.Copy
        End With
        
        .Cells(1).PasteSpecial 12
        With .UsedRange
        .Columns(1).SpecialCells(4).FormulaR1C1 = "=R[-1]C"
        .Columns(3).Insert
        .Columns(3).Formula = "=A1&B1"
        .Columns(3).NumberFormat = "@"
        .Value = .Value
        .Cells(1, 3) = "string"
        .Columns.AutoFit
        End With
    End With
    
    Application.ScreenUpdating = True
End Sub

 

[Ginger]

Ha ha ha... Altijd leuk om te zien hoe de grootheden weer hélemaal los kunnen gaan op een vraag. Ik was het spoor al kwijt bij mijn initiele vraag, laat staan wat jullie NU aan 't doen zijn. :d
Ik was al tevreden met wat ik nu had, maar als ik volgende week ff wat extra tijd heb, zal ik toch de nieuwe oplossingen ook nog 'ns proberen. Mijn dank tot zover, maar speel uiteraard gerust verder.

 

[snb]

Ik vond mijn aanpak met Dictionary met 2 lussen toch niet zo fraai; zie de eerste code.

Vevolgens heb ik gekeken wat 'evaluate' kan betekenen; die zal voorspelbaar niet snel zijn en loopt alleen goed als het werkblad met gegevens aktief is. zie de tweede code.

Sub M_snb_eenlussig()
  sn = Sheets("Input_van_VPIG").Cells(1).CurrentRegion
    
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      c00 = sn(j, 1) & "_" & sn(j, 2) & "_" & sn(j, 1) & sn(j, 2)
      .Item(c00) = Val(.Item(c00)) + sn(j, 3) & "_" & c00
    Next
    sn = .items
  End With
  
  With CreateObject("New:{8BD21D20-EC42-11CE-9E0D-00AA006002F3}")
    .List = sn
    Sheets("output_voor_analyse").Cells(1).Resize(.ListCount) = .List
  End With
     
  Application.DisplayAlerts = False
  Sheets("output_voor_analyse").Cells(1, 1).CurrentRegion.Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, "_"
End Sub

Sub M_snb_evaluate()
   Sheets("input_van_VPIG").Activate
   sn = [index(A2:A2000&"_"&B2:B2000&"_"&A2:A2000&B2:B2000&"_"&sumifs(C2:C2000,A$2:A$2000,A2:A2000,B2:B2000,B2:B2000),)]
   
   With CreateObject("scripting.dictionary")
      For Each it In sn
        x0 = .Item(it)
      Next
      Sheets("output_voor_analyse").Cells(1, 20).Resize(.Count) = Application.Transpose(.keys)
    End With
    
    Application.DisplayAlerts = False
    Sheets("output_voor_analyse").Cells(1, 20).CurrentRegion.Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, "_"
End Sub

 

[E v R]

Eenlussig op 85K rijen 5,460938
Evaluate draait nog steeds na 10 min.... maar afgebroken

@Ginger, zeker doen! Dat losgaan..... gebeurt wel vaker bij jouw draadjes heh :d Goede, leuke en interessante vragen dus :thumb: (daarnaast wat extra aandacht voor een zeer gerespecteerde 'helper' is toch logisch ) (sowieso wat mij betreft )

 

[HSV]

Snelheid in verhouding tot de anderen niet gemeten; ook geen tijd gehad om aan de vraag echt aandacht te besteden.

Sub hsv()
sn = Sheets("input_van_VPIG").Cells(1).CurrentRegion
Set dic = CreateObject("scripting.dictionary")
  For i = 2 To UBound(sn)
    dic.Item(sn(i, 1) & "_" & sn(i, 2) & "_" & sn(i, 1) & sn(i, 2)) = dic.Item(sn(i, 1) & "_" & sn(i, 2) & "_" & sn(i, 1) & sn(i, 2)) + sn(i, 3)
       sn(dic.Count, 2) = dic.keys()(dic.Count - 1)
       sn(dic.Count, 1) = dic.Item(dic.keys()(dic.Count - 1))
  Next
With Sheets("output_voor_analyse").Cells(1)
  .Resize(dic.Count, 2) = sn
  .CurrentRegion.Columns(2).TextToColumns , , , , 0, 0, 0, 0, -1, "_"
End With
End Sub

 

[snb]

@E v R

Dank voor de test.

Evaluate loopt zoals verwacht: geen optie dus

Wat me wel verbaast is, dat het script duidelijk sneller blijkt te zijn dan Powerquery.
Wat mij ook verbaast is dat MS in Powerquery blijkbaar geen gebruik heeft gemaakt van de ADO-technologie.
Dan lijkt Powerquery een grafische UI-uitbreiding met een suboptimale techniek. (correct me if I'm wrong)

@HSV
slim :thumb:

Zette me aan het denken tot:

Sub M_hsv_snb()
  sn = Sheets("input_van_VPIG").Cells(1).CurrentRegion.Resize(, 4)
    
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      c00 = sn(j, 1) & sn(j, 2)
      .Item(c00) = .Item(c00) + sn(j, 3)
      sn(.Count, 1) = sn(j, 1)
      sn(.Count, 2) = sn(j, 2)
      sn(.Count, 3) = c00
      sn(.Count, 4) = .Item(c00)
    Next
      
    Sheets("output_voor_analyse").Cells(1, 30).Resize(.Count, UBound(sn, 2)) = sn
  End With
End Sub

 

[HSV]

Zette me aan het denken tot:

Die fietst er snel doorheen.

 

[E v R]

Nog even getest op de 85K rijen:

hsv_snb 4,835938
hsv na een aantal minuten maar afgekapt

Wat me wel verbaast is, dat het script duidelijk sneller ......... suboptimale techniek. (correct me if I'm wrong)

Verbaasde mij ook, hoewel de uitkomst in PowerQuery meteen in een opgemaakte tabel staat, geen VBA nodig is en wellicht nog wat andere voordelen heeft. Maar ik had het sneller verwacht

 

[snb]

Gaar niet schlecht die hsv_snb performance.

Ik probeerde het ook nog met een querytabel, maar met name de sum en de group by wil in mijn vorm niet lukken.
Wellicht weet een ODBC-specialist raad ?

Sub M_snb_querytable()
     Sheet3.QueryTables.Add("ODBC;DSN=Excel files;DBQ=" & ThisWorkbook.FullName, Sheet3.Cells(1, 10), "SELECT  afne, arti, afne&arti, aant FROM `Input_van_VPIG$` ").Refresh False
End Sub

 

[E v R]

als je het op dezelfde manier probeert als in de posten #12 #15 dus in de Group BY alle kolommen noemen welke ook in de SELECT zijn opgenomen.

 Sheet3.QueryTables.Add("ODBC;DSN=Excel files;DBQ=" & ThisWorkbook.FullName, Sheet3.Cells(1, 10), "SELECT afne, arti ,afne&arti, sum(aant) FROM `Input_van_VPIG$` GROUP BY   afne, arti, afne&arti  ").Refresh False

Dan kom ik op

7,902344 (nieuwe query)
6,640625 (bestaande refresh)

 

[snb]

@ E v R

Mijn dank is dubbel.
Ik kreeg hem niet aan de praat; nu hopelijk wel met jouw aanwijzingen.

Zo'n snelheidsresultaat is natuurlijk ook erg informatief.
Dat komt zo'n beetje overeen met de Powerquery ?

 

[E v R]

Ja komt inderdaad overeen met PQ, de ADO-variant blijft toch wel de TGV onder de opties

weliswaar allemaal summier getest op 85K rijen met 84215 unieke rijen als uitkomst

 

[snb]

Ik heb er nog twee voor je

Sub M_snb_listobject()
   With Sheet3.ListObjects.Add(0, "ODBC;DSN=Excel files;DBQ=" & ThisWorkbook.FullName, True, xlYes, Sheet3.Cells(1, 10)).QueryTable
        .CommandText = "SELECT afne, arti ,afne&arti, sum(aant) FROM `Input_van_VPIG$` GROUP BY   afne, arti, afne&arti  "
        .Refresh False
    End With
End Sub

Sub M_snb_querytable_002()
  With ThisWorkbook.Connections.Add("snb_dicht", " ", "ODBC;DSN=Excel files;DBQ=" & ThisWorkbook.FullName, "SELECT afne, arti ,afne&arti, sum(aant) FROM `Input_van_VPIG$` GROUP BY   afne, arti, afne&arti  ").ODBCConnection
      Sheet3.QueryTables.Add(.Connection, Sheet3.Cells(1, 10), .CommandText).Refresh False
  End With
End Sub

PS. Excel blijft me verbazen.....

 

[E v R]

Als het jou nog steeds verbaast....:d

Op de 85K rijen:

M_snb_listobject 7,230469
M_snb_querytable_002 8,507813