VBA - cellen vergelijken en vervolgens cel aanpassen

[Pas Cal]

Goede dag,

Ik heb een bestand met +/- 70.000 regels. Ik wil een cellen vergelijken of deze voorkomt in een kolom. Dit kost met =vergelijken veel tijd. 

Bijgevoegd een voorbeeld. 

De bedoeling is wanneer in kolom A bij de betreffende regel 99999 staat, dat dan kolom C vergeleken wordt of de naam in kolom B (geheel) voorkomt. Wanneer dit zo is, moet in kolom F '1' gezet worden. In het voorbeeld zou alleen F2 naar '1' gezet moeten worden omdat Klaas (C2) voorkomt in kolom B.
Is dit mogelijk met een macro? Zo ja, heeft iemand een opzetje?

Testbestand.xlsx

[Pas Cal]

48 minuten geleden, dotchiejack zei:

Zo?

Sub Dotch()
    For j = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Cells(j, 4).Value = "=IF(RC[-3]=99999,ISERROR(MATCH(RC[-1], C[-2],0)),""Geen 99999"")"
        Cells(j, 5).Value = "=IF(RC[-1] = FALSE,1,0)"
Next
End Sub

Ctrl + q toetsen gebruiken in het voorbeeldje om het resultaat te zien.

pchelpforum.xlsb 13 kB · 2 downloads

Niet precies. Nu plaatst de macro alsnog een formule zodat de sheet langzaam wordt. Het is de bedoeling dat  binnen de macro gecheckt wordt of de betreffende cel in Kolom C voorkomt in kolom B. Zo ja, dan enkel een 1 zetten in kolom E.

[bakerman]

Hoe doet deze het ?

 

Sub tst()
    Set dic = CreateObject("scripting.dictionary")
    sn = Cells(1).CurrentRegion.Value
    For i = 2 To UBound(sn)
        x0 = dic.Item(sn(i, 2))
    Next
    For j = 2 To UBound(sn)
        If (sn(j, 1) = 99999) * (dic.exists(sn(j, 3))) Then sn(j, 5) = 1
    Next
    Cells(1).Resize(UBound(sn), UBound(sn, 2)) = sn
End Sub

 

[Pas Cal]

15 uren geleden, bakerman zei:

Hoe doet deze het ?

 

Sub tst()
    Set dic = CreateObject("scripting.dictionary")
    sn = Cells(1).CurrentRegion.Value
    For i = 2 To UBound(sn)
        x0 = dic.Item(sn(i, 2))
    Next
    For j = 2 To UBound(sn)
        If (sn(j, 1) = 99999) * (dic.exists(sn(j, 3))) Then sn(j, 5) = 1
    Next
    Cells(1).Resize(UBound(sn), UBound(sn, 2)) = sn
End Sub

 

 

edit: werkt perfect, dank u!

24 juni 2021 aangepast door Pas Cal

[bakerman]

Dan komt jouw voorbeeldbestand niet overeen met het werkelijke want draai deze maar eens.

Pas Cal.xlsm

[Pas Cal]

8 uren geleden, bakerman zei:

Dan komt jouw voorbeeldbestand niet overeen met het werkelijke want draai deze maar eens.

Pas Cal.xlsm 14 kB · 0 downloads

 

Werkt inderdaad prima, had een kolom leeg gemaakt.  Super bedankt!

[bakerman]

Graag gedaan. Hoe valt de snelheid mee ?

 

Heb de code nog wat verder aangepast zodat nu eerst de oude resultaten in kolom E gewist worden.

 

Ook worden nu enkel de resultaten terug naar het werkblad geschreven zodat de rest van je data onaangeroerd blijft.

 

Sub tst()
    Dim b()
    Set dic = CreateObject("scripting.dictionary")
    sn = Cells(1).CurrentRegion.Value
    ReDim b(1 To UBound(sn) - 1, 1 To 1)
    For i = 2 To UBound(sn)
        x0 = dic.Item(sn(i, 2))
    Next
    For j = 2 To UBound(sn)
        If (sn(j, 1) = 99999) * (dic.exists(sn(j, 3))) Then b(j - 1, 1) = 1
    Next
    lRow = Range("E" & Rows.Count).End(xlUp).Row: If lRow = 1 Then lRow = 2
    Range("E2:E" & lRow).ClearContents
    Cells(2, 5).Resize(UBound(b), 1) = b
End Sub