Vergelijking met meerdere kolommen

Phill · 24 okt 2015

Dank zij dit forum heb ik een macro ontvangen, die de gegevens uit twee tabbladen vergelijkt. De vergelijking wordt gedaan uit kolom A.
Nu wil ik echter dat de vergelijking gedaan wordt met Kolom A, B en C.
Met andere woorden, pas als alle drie de kolommen dezelfde gegevens bevatten dient de gehele rij gekopieerd te worden naar Blad 4

Onderstaand de destijds ontvangen macro.

Sub hsv()
Dim cl As Range, c As Range
For Each cl In Blad2.Columns(1).SpecialCells(2)Bekijk bijlage Map1.xls
Set c = Blad1.Columns(1).Find(cl, , , xlWhole)
If c Is Nothing Then
Blad4.Cells(Rows.Count, 1).End(xlUp).Offset(1).EntireRow.Value = cl.EntireRow.Value
End If
Next cl
End Sub

Bekijk bijlage Map1.xls

Alvast bedankt

HSV · 24 okt 2015

Om in die code te blijven.

Code:

Sub hsv()
Dim cl As Range, c As Range
For Each cl In Blad2.Columns(1).SpecialCells(2)
Set c = Blad1.Columns(1).Find(cl, , , xlWhole)
  If Not c Is Nothing Then
    If Join(Application.Index(c.Resize(, 3).Value, 1, 0)) = Join(Application.Index(cl.Resize(, 3).Value, 1, 0)) Then
       Blad4.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3) = cl.Resize(, 3).Value
    End If
  End If
Next cl
End Sub

Anders in een array.

Code:

Sub hsv()
Dim sn, sn1, arr, i As Long, ii As Long
sn = Blad2.Cells(2, 1).CurrentRegion
sn1 = Blad1.Cells(2, 1).CurrentRegion
ReDim arr(UBound(sn), 2)
For i = 1 To UBound(sn)
  For ii = 1 To UBound(sn1)
    If sn(i, 1) & "|" & sn(i, 2) & "|" & sn(i, 3) = sn1(ii, 1) & "|" & sn1(ii, 2) & "|" & sn1(ii, 3) Then
       arr(n, 0) = sn1(ii, 1)
       arr(n, 1) = sn1(ii, 2)
       arr(n, 2) = sn1(ii, 3)
       n = n + 1
     End If
   Next ii
  Next i
Blad4.Cells(1, 8).Resize(n, 3) = arr
End Sub

sylvester-ponte · 24 okt 2015

ik ben toch benieuwd:

bevatten die lijsten alleen unieke regels ?

en zo niet mogen er dan dubbelen in blad 4 komen?

VenA · 24 okt 2015

Eigenlijk wel hetzelfde idee als HSV maar iets anders geschreven

Code:

Sub VenA()
ar = Sheets(1).Cells(1).CurrentRegion
ar1 = Sheets(2).Cells(1).CurrentRegion
With Sheets(4)
    .Cells.ClearContents
    For j = 1 To UBound(ar)
        For jj = 1 To UBound(ar1)
            c00 = ar(j, 1) & "|" & ar(j, 2) & "|" & ar(j, 3)
            If c00 = ar1(jj, 1) & "|" & ar1(jj, 2) & "|" & ar1(jj, 3) Then .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(, 3) = Split(c00, "|")
        Next jj
    Next j
End With
End Sub

HSV · 24 okt 2015

Die pipe is geen slecht idee VenA. :thumb:

Maar tussentijds wegschrijven kost tijd en doe ik alleen als het niet anders kan , vandaar ook de array maar toegevoegd.

sylvester-ponte · 24 okt 2015

of deze hij geeft allen de unieken.
de meeste code komt van VenA:

Code:

Sub alleenUnieken()
    ar = Sheets(1).Cells(2).CurrentRegion
    ar1 = Sheets(2).Cells(2).CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    With Sheets(4)
        .Cells.ClearContents
        For j = 1 To UBound(ar)
            c00 = d.Item(ar(j, 1) & "|" & ar(j, 2) & "|" & ar(j, 3))
        Next j
        For jj = 1 To UBound(ar1)
            c00 = ar1(jj, 1) & "|" & ar1(jj, 2) & "|" & ar1(jj, 3)
            If d.exists(c00) Then
                d.Remove (c00)
                .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(, 3) = Split(c00, "|")
            End If
        Next jj
    End With
End Sub

HSV · 24 okt 2015

Om in de array omgeving te blijven voor unieke.

Code:

Sub hsvtwee()
Dim sn, sn1, arr, i As Long, ii As Long, b(2)
sn = Blad2.Cells(2, 1).CurrentRegion
sn1 = Blad1.Cells(2, 1).CurrentRegion
Set dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(sn)
  For ii = 1 To UBound(sn1)
   If sn(i, 1) & "|" & sn(i, 2) & "|" & sn(i, 3) = sn1(ii, 1) & "|" & sn1(ii, 2) & "|" & sn1(ii, 3) Then
    a = dic.Item(sn1(ii, 1) & "|" & sn1(ii, 2) & "|" & sn1(ii, 3))
     If IsEmpty(a) Then a = b
        a(0) = sn1(ii, 1)
        a(1) = sn1(ii, 2)
        a(2) = sn1(ii, 3)
     dic.Item(sn1(ii, 1) & "|" & sn1(ii, 2) & "|" & sn1(ii, 3)) = a
     End If
   Next ii
  Next i
Blad4.Cells(1, 8).Resize(dic.Count, 3) = Application.Index(dic.items, 0, 0)
End Sub

Of zonder de dictionary wat nog iets sneller is.

Code:

Sub hsvdrie()
Dim sn, sn1, i As Long, ii As Long, c00 As String, n As Long
t = Timer
sn = Sheets("nieuw").Cells(1).CurrentRegion
sn1 = Sheets("oud").Cells(1).CurrentRegion
ReDim arr(UBound(sn), 2)
For i = 2 To UBound(sn)
 For ii = 2 To UBound(sn1)
    If sn(i, 1) & "|" & sn(i, 2) & "|" & sn(i, 3) = sn1(ii, 1) & "|" & sn1(ii, 2) & "|" & sn1(ii, 3) Then
        If InStr(c00, sn1(ii, 1) & "|" & sn1(ii, 2) & "|" & sn1(ii, 3) & "||") = 0 Then
             c00 = c00 & sn1(ii, 1) & "|" & sn1(ii, 2) & "|" & sn1(ii, 3) & "||"
                      arr(n, 0) = sn1(ii, 1)
                      arr(n, 1) = sn1(ii, 2)
                      arr(n, 2) = sn1(ii, 3)
         End If
       End If
     Next ii
   n = n + 1
 Next i
Sheets("blad4").Cells(1, 12).Resize(UBound(arr), 3) = arr
MsgBox Timer - t
End Sub

Phill · 25 okt 2015

Sorry, maar geen van allen werkt.
Ik zal het anders uitleggen:
In blad 1 staan zaken van dag 1
In blad 2 staan zaken van dag 2
In blad 3 wil ik graag de zaken hebben staan, die niet in blad 2 staan. Dus die op dag 1 zijn afgehandeld. Er moet dan een vergelijking plaatsvinden op kolom 1, 2 EN 3. Dus pas als in blad 2 geen overeenkomst is op deze drie kolommen, dan pas komt hij in blad 3. (en dan de gehele rij)

Vervolgens wil ik ook nog in blad 4 de zaken hebben staan die wel in blad 2 voorkomen, maar niet in blad 1, dus de nieuwe zaken. Ook hier moet gekeken worden of alle drie de kolommen overeenkomen. Het kan voorkomen dat kolom 1 hetzelfde is, maar dat kolom 2 of 3 afwijkt. Dan is het een nieuwe zaak en moet deze in blad 4 terechtkomen.

Ik heb een nieuw voorbeeld bestand bijgevoegd, waarbij ik in het blad resultaat gezet hebt, wat er in blad 3 en blad 4 zou moeten komen.

Bekijk bijlage Test2.xls

HSV · 25 okt 2015

De code past uitstekend bij je openingsvraag.

Edit: Nu ik tabblad resultaat zo zie kan je 1 op 1 kopiëren.
Blad1 gaat naar Blad3, en Blad2 naar Blad4.

Phill · 25 okt 2015

HSV zei:
De code past uitstekend bij je openingsvraag.

Edit: Nu ik tabblad resultaat zo zie kan je 1 op 1 kopiëren.
Blad1 gaat naar Blad3, en Blad2 naar Blad4.

Phill · 25 okt 2015

Sorry ik begrijp je opmerking niet van 1 op 1 overnemen. De rijen die in blad 1 staan maar niet in blad 2 moeten naar blad 3. Deze zijn afgehandeld. Zaken die zowel in blad 1 en blad 2 staan zijn niet afgehandeld en hoeven nergens naar toe. Tevens wordt in jouw macro niet de gehele rij meegenomen.

Rijen in blad twee die niet voorkomen in blad 1 gaan naar blad 4.
Bij het testen van jouw code wordt niet de gehele rij meegenomen, maar neemt hij ook de verkeerde zaken mee.

HSV · 25 okt 2015

Bekijk je openingsvraag en je voorbeeldbestand.
Er staat alleen maar iets in drie kolommen, en daar passen de codes uitstekend bij.
Lege cellen blijven leeg, dus daar doen we niets mee.

Maar als jij de vraag gaat veranderen en het bestand anders is dan je eerste, zouden wij de codes moeten aanpassen.

Beetje jammer van de tijd die we er in hebben gestoken, vind je niet?

Phill · 25 okt 2015

Sorry dat ik het niet duidelijk genoeg verwoord heb. Ik gaf wel aan dat de gehele rij gekopieerd moest worden. Ik had wellicht het uitgebreide bestand moeten meesturen

Timshel · 25 okt 2015

Probeer het eens met deze:

Code:

Sub tsh()
    Dim Br
    Dim i As Long
    Dim Sl As String
    
    With CreateObject("Scripting.Dictionary")
        Br = Sheets("Blad1").Cells(1).CurrentRegion
        For i = 2 To UBound(Br)
            .Item(Join(Array(Br(i, 1), Br(i, 2), Br(i, 3)), "|")) = Application.Index(Br, i, [Column(A:R)])
        Next
        Br = Sheets("Blad2").Cells(1).CurrentRegion
        For i = 2 To UBound(Br)
            Sl = Join(Array(Br(i, 1), Br(i, 2), Br(i, 3)), "|")
            If .Exists(Sl) Then
                .Remove Sl
            Else
                Sheets("Blad4").Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(, 18) = Application.Index(Br, i, [Column(A:R)])
            End If
        Next
        Sheets("Blad3").Cells(2, 1).Resize(.Count, 18) = Application.Index(.Items, 0)
    End With
End Sub

Phill · 25 okt 2015

Helaas, het volgende klopt niet:
In blad 3 ontbreekt 01-700416-75 (Er zit een verschil in kolom 3 op blad 1 en 2)

In blad 4 zijn 6 lege rijen, voordat de nieuwe zaak wordt vermeld en er ontbreken 3 rijen die er ook in zouden moeten staan:
01-700416-75, 05-001335-14 en 01-665551-93

Timshel · 25 okt 2015

De 01-700416-75 is in het voorbeeld wel degelijk identiek in beide bladen, ook in kolom 3. Het klopt dus dat dat record ontbreekt in de uitvoer.
Er zit inderdaad nog een bugje in de routine waardoor de uitvoer in Blad4 soms niet klopt. Zo moet het worden:

Code:

Sub tsh()
    Dim Br
    Dim i As Long
    Dim Sl As String
    
    With CreateObject("Scripting.Dictionary")
        Br = Sheets("Blad1").Cells(1).CurrentRegion
        For i = 2 To UBound(Br)
            .Item(Join(Array(Br(i, 1), Br(i, 2), Br(i, 3)), "|")) = Application.Index(Br, i, [Column(A:R)])
        Next
        Br = Sheets("Blad2").Cells(1).CurrentRegion
        For i = 2 To UBound(Br)
            Sl = Join(Array(Br(i, 1), Br(i, 2), Br(i, 3)), "|")
            If .Exists(Sl) Then
                .Remove Sl
            Else
                Sheets("Blad4").Range("A" & [COLOR="#FF0000"]Sheets("Blad4")[/COLOR].Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(, 18) = _
                    Application.Index(Br, i, [Column(A:R)])
            End If
        Next
        Sheets("Blad3").Cells(2, 1).Resize(.Count, 18) = Application.Index(.Items, 0)
    End With
End Sub

Phill · 25 okt 2015

Je hebt gelijk v.w.b. 01-700416-75
Maar in blad 4 ontbreken dan nog wel de twee andere zaken en heb ik lege rijen.

Phill · 25 okt 2015

Ik was wat te vlug met reageren. Je nieuwe macro werkt perfect.
Heel hartelijk bedankt!

Timshel · 25 okt 2015

Fijn dat de oplossing naar wens is.
Wil je de vraag nog op opgelost zetten?

Phill · 26 okt 2015

Ik heb iets raars ontdekt.
In blad 4 zijn sommige datums van kolom L en P in Amerikaanse datumnotatie vermeld.
Hoe kan dit? In principe moet hij de datums overnemen zoals deze vermeld staat in blad 2.
Hij doet dit ook niet bij alle rijen.
Ditzelfde geldt voor blad 3.

Ik heb de bijlage bijgevoegd en de datums rood gemaakt. Ik snap niet wat hier gebeurd.

PHP:

Bekijk bijlage Test2.xls

Vergelijking met meerdere kolommen

Verenigingslid

Inventaris

Verenigingslid

Inventaris

Inventaris

Verenigingslid

Inventaris

Verenigingslid

Inventaris

Verenigingslid

Verenigingslid

Inventaris

Verenigingslid

Terugkerende gebruiker

Verenigingslid

Terugkerende gebruiker

Bijlagen

Verenigingslid

Verenigingslid

Terugkerende gebruiker

Verenigingslid

Wij waarderen jouw privacy