Grote bestanden formules toevoegen

[Boboes]

Ik heb een werkblad ‘Vergelijken’ met 250.000 regels en 4 kolommen (A t/m D). Binnen dat blad worden via VBA formules toegevoegd in de kolommen E t/m I. Die formules maken voornamelijk gebruik van de MATCH-functie waarbij gezocht moet worden in een aantal andere bereiken (more_id, more_sleutel1 en more_sleutel2) in andere werkbladen.
- Bereik ‘more_id’ bevat 40.000 regels (1 kolom)
- Bereik ‘more_sleutel1’ bevat 450.000 regels (1 kolom)
- Bereik ‘more_sleutel2’ bevat 450.000 regels (1 kolom)

Zie hieronder de code om de formules te genereren.

Bij een veel kleinere populatie van de bereiken werkt de code op zich goed en duurt het niet te lang, maar bij bovengenoemde bereiken duurt het een eeuwigheid….

Hoe kan de code sneller uitgevoerd worden? Ik heb de Calculation aan begin al uitgezet maar dat helpt niet. Kan het misschien met CreateObject(“scripting.dictionary”)? Ik zie die optie af en toe voorbij komen maar weet niet of dat de oplossing is en hoe dat werkt en of dat ingepast kan worden in mijn code.

Sub VergelijkingMaken()

    Dim sht As Worksheet
    
    With Application
       .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Set sht = ThisWorkbook.Sheets("Vergelijken")
    
    With sht
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row

        .Range("E2:E" & LR).FormulaR1C1 = _
            "=IF(ISERROR(MATCH(RC1,more_id,0)),""Nee"",""Ja"")"
        .Range("F2:F" & LR).FormulaR1C1 = _
            "=RC1&RC2"
        .Range("G2:G" & LR).FormulaR1C1 = _
            "=IF(ISERROR(MATCH(RC[-1],more_sleutel1,0)),""Nee"",""Ja"")"
        .Range("H2:H" & LR).FormulaR1C1 = _
            "=IF(ISERROR(MATCH(RC[-2],more_sleutel2,0)),""Nee"",""Ja"")"
        .Range("I2:I" & LR).FormulaR1C1 = _
            "=IF(ISERROR(MATCH(""Ja"",RC[-2]:RC[-1],0)),""Nee"",""Ja"")"
        'Formules omzetten naar waarden
        .Range("E2:I" & Rij).Value = .Range("E2:I" & Rij).Value

    End With
    
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
End Sub

 

[snb]

Werk in VBA zonder excelformules; gebruik arrays en 3 dictionaries en plaats een voorbeeldbestand.

 

[Boboes]

Als bijlage een voorbeeldbestand toegevoegd met slechts een beperkt aantal fictieve gegevens.

 

[NoellaG]

Misschien is het tijd om over te stappen naar een database applicatie?

 

[snb]

Lijkt me niet:

Sub M_snb()
   sn = Blad6.Cells(1).CurrentRegion.Resize(, 4)
   
   s_01 = Blad4.Cells(1).CurrentRegion
   s_02 = Blad2.Cells(1).CurrentRegion
   s_03 = Blad3.Cells(1).CurrentRegion
   
   Set d_01 = CreateObject("scripting.dictionary")
   Set d_02 = CreateObject("scripting.dictionary")
   Set d_03 = CreateObject("scripting.dictionary")

   For j = 2 To UBound(s_01)
      x0 = d_01.Item(s_01(j, 1))
   Next
   For j = 2 To UBound(s_02)
      x0 = d_02.Item(s_02(j, 1))
   Next
   For j = 2 To UBound(s_03)
      x0 = d_03.Item(s_03(j, 1))
   Next
   
   For j = 2 To UBound(sn)
     sn(j, 3) = d_01.exists(sn(j, 1))
     sn(j, 4) = d_02.exists(sn(j, 1) & sn(j, 2))
     If Not sn(j, 4) Then sn(j, 4) = d_03.exists(sn(j, 1) & sn(j, 2)) & " in output B"
   Next
   
   Blad6.Cells(1).CurrentRegion.Resize(, 4) = sn
End Sub

 

[Boboes]

Keigoed snb! Werkt als een tierelier. Ik kan de code grotendeels volgen en snap nu hoe het een beetje werkt, maar het is voor mij nog wel wat abacadabra. N.a.v. jouw eerdere opmerking ben ik me nu ook meer aan het verdiepen in array's. Heb dat nog niet vaak toegepast maar zie nu wel dat dit beter en sneller is wanneer je met zeer grote bestanden werkt. Leerzaam!
Hartstikke bedankt snb! :thumb:

 

[snb]

Je kunt een werkblad in Excel gewoon als een grafische weergave van een 2-di,mensionele Array beschouwen.

 

[Boboes]

Als ik het goed begrijp is het 2-dimensionaal omdat een werkblad alleen kolommen en rijen bevat, toch?
Zojuist overigens jouw oplossing verwerkt in een realistisch megabestand (met enkele honderd duizenden regels) en gedraaid: verwerking duurde ongeveer één minuut! Nogmaals dank.

 

[snb]

Dat klopt.

Overigens zou ik voor ieder werkblad een aparte kolom nemen, zodat je meteen kunt zien wat in welk werkblad aan de hand is:

Sub M_snb()
   sn = Blad6.Cells(1).CurrentRegion.Resize(, 5)
   
   s_01 = Blad4.Cells(1).CurrentRegion
   s_02 = Blad2.Cells(1).CurrentRegion
   s_03 = Blad3.Cells(1).CurrentRegion
   
   Set d_01 = CreateObject("scripting.dictionary")
   Set d_02 = CreateObject("scripting.dictionary")
   Set d_03 = CreateObject("scripting.dictionary")

   For j = 2 To UBound(s_01)
      x0 = d_01.Item(s_01(j, 1))
   Next
   For j = 2 To UBound(s_02)
      x0 = d_02.Item(s_02(j, 1))
   Next
   For j = 2 To UBound(s_03)
      x0 = d_03.Item(s_03(j, 1))
   Next
   
   For j = 2 To UBound(sn)
     sn(j, 3) = d_01.exists(sn(j, 1))
     sn(j, 4) = d_02.exists(sn(j, 1) & sn(j, 2))
     If Not sn(j, 4) Then sn(j, 5) = d_03.exists(sn(j, 1) & sn(j, 2))
   Next
   
   Blad6.Cells(1).CurrentRegion.Resize(, 5) = sn
   Blad6.Cells(1, 3).Resize(, 3) = Array(Blad4.Name, Blad2.Name, Blad3.Name)
End Sub