Twee kolommen vergelijken in 2 verschillende werkbladen en indien gelijk samenvoegen

Status
Niet open voor verdere reacties.
V

Veldenvdt

Gebruiker
Lid geworden
4 mei 2012
Berichten
23
Hallo allemaal,

Ik ben op zoek naar een vba code die mij kan helpen met het volgende:

Ik wil kolom 1 van werkblad 1 vergelijken met kolom 1 van werkblad 2. De te vergelijken waarde is een nummer. In werkblad 1 zijn 4 kolommen gevuld en in werkblad 2 zijn 6 kolommen gevuld.

Indien het nummer van kolom 1 in werkblad 1 overeenkomt met het nummer van kolom 1 in werkblad 2 dan moet in werkblad 3 de hele rij uit werkblad 1 (4 kolommen) en werkblad 2 (6 kolommen) gekopieerd worden naar werkblad 3. Dit mag achter elkaar: eerst de gegevens uit werkblad 1 en daarachter de gegevens uit werkblad 2

Mocht een nummer alleen in kolom 1 voorkomen van werkblad 1 of in kolom 1 van werkblad 2 dan moet de inhoud van die regel gekopeerd worden naar werkblad 4,
waarbij indien het nummer alleen voorkomt in werkblad 1 de gegevens worden geplaatst in kolom A t/m D van werkblad 4 en indien het nummer alleen voorkomt in werkblad 2 dan dienen de kolommen E t/m J gevuld worden in werkblad 4.

Mocht het voorkomen dat een nummer in werkblad 1 en/of 2 meerdere malen voorkomt dan mag niks gekopieerd worden naar werkblad 3 maar moet indien in werkblad 1 het nummer meer dan 1 keer voorkomt de gegevens uit die rijen naar werkblad vijf worden gekopieerd (kolom a t/m d) en indien het nummer in werkblad 2 meer dan 1 keer voorkomt dan dienen de gegevens uit die rijen ook naar werkblad 5 te worden gekopieerd (naar kommen e t/m j).
Ik ben benieuwd naar de oplossingen!!
Alvast bedankt

Theo
 
Visual Basic is iets anders dan Visual Basic for Applications, VBA is programmeren binnen Office applicaties. Verplaatst naar juiste sectie.
 
Hallo allemaal,

Omdat de vraagstelling best complex is heb ik een voorbeeldbestandje uitgewerkt.

De bedoeling is dus dat kolom a van werkblad 1 vergeleken wordt met kolom a van werkblad 2.

Er ontstaan dan de volgende mogelijkheden:

1. Een nummer komt 1 maal voor in kolom A van werkblad 1 en 1 maal voor in kolom a van werkblad 2. De gegevens moeten achter elkaar geplaatst worden in werkblad 3
2. Een nummer komt eenmaal voor in werkblad 1 en 2 of meer keer in werkblad 2. Gegevens plaatsen in werkblad 5. Dit kan natuurlijk ook andersom voorkomen (meerdere malen in 2 en 1 maal in werkblad 1)
3. Een nummer komt 2 maal of meer voor in werkblad 1 en niet in werkblad 2. Gegevens plaatsen in werkblad 5. Dit kan natuurlijk ook andersom voorkomen.
4. Een nummer komt eenmaal voor in werkblad 1 of eenmaal voor in werkblad 2. Gegevens plaatsen in werkblad 4.

Het is de bedoeling dat de vergelijking begint in werkblad 1 en vervolgens verder gaat met werkblad 2

Ik hoop dat deze informatie tezamen met het bestand meer informatie verstrekt over de bedoeling.

Met vriendelijke groet,

Theo
 

Bijlagen

2 kolommen vergelijken

Hallo Allemaal,

Ik heb geen reactie gekregen om mijn vraagstelling. Ik heb daarom een nieuw testbestand bijgevoegd en de vraagstgelling opnieuw geformuleerd. Ik hoop nu duidelijker.

Het testbestand bestaat uit 5 werkbladen, t.w. bron1, bron2, uitkomst1, uitkomst2 en uitkomst3.

Wat is de vraagstelling?

1. Zoek in kolom A van bron1 naar een nummer dat slechts eenmaal voorkomt in bron1 en ook eenmaal voorkomt in kolom A van bron2.
Indien ja kopieer dan de hele regel uit bron1 naar uitkomst1 en kopieer tevens het bedrag in kolom B van bron2 naar uitkomst1.
(zie uitwerking uitkomst1).

2. Zoek in kolom A van bron1 naar dubbels nummers (of nummers die meer voorkomen dan 2) en indien ja kopieer dan de gehele regels naar uikomst2
Komt in kolom A van bron2 datzelfde nummer ook eenmaal of meer voor plaats dan het bedrag van kolom B van bron2 eveneens in uitkomst2 (zie uitwerking uitkomst2).

3. Zoek in kolom A van bron2 naar nummers die slechts eenmaal voorkomen en indien ja plaats dan de gehele regel in uitkomst3.

4. Zoek in kolm A van bron2 naar dubbele nummers (of meer) die niet voorkomen in bron1 en indien ja kopieer dan de gehele regel naar uiktomst2.
 

Bijlagen

Hier kan je al mee starten.
Code: 
Sub test()
lRowBr1 = Sheets("Bron1").Range("A" & Rows.Count).End(xlUp).Row
lRowBr2 = Sheets("Bron2").Range("A" & Rows.Count).End(xlUp).Row
With Sheets("Bron1")
For Each cl In .Range("A2:A" & lRowBr1)
    Select Case WorksheetFunction.CountIf(.Range("A2:A" & lRowBr1), cl.Value)
    Case 1
        If WorksheetFunction.CountIf(Sheets("Bron2").Range("A2:A" & lRowBr2), cl.Value) = 1 Then
            cl.Resize(, 4).Copy Sheets("Uitkomst1").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Sheets("Uitkomst1").Range("A" & Rows.Count).End(xlUp).Offset(, 4) = Sheets("Bron2").Columns(1).Find(cl.Value, , xlValues, xlWhole).Offset(, 1).Value
        End If
    Case Is > 1
        cl.Resize(, 4).Copy Sheets("Uitkomst2").Range("A" & Rows.Count).End(xlUp).Offset(1)
    
    End Select
Next
End With
With Sheets("Bron2")
For Each cl In .Range("A2:A" & lRowBr2)
    Select Case WorksheetFunction.CountIf(.Range("A2:A" & lRowBr2), cl.Value)
    Case 1
        cl.Resize(, 2).Copy Sheets("Uitkomst3").Range("A" & Rows.Count).End(xlUp).Offset(1)
    Case Is > 1
        If WorksheetFunction.CountIf(Sheets("Bron1").Range("A2:A" & lRowBr1), cl.Value) = 0 Then
            cl.Copy Sheets("Uitkomst2").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Sheets("Uitkomst2").Range("A" & Rows.Count).End(xlUp).Offset(, 4) = cl.Offset(, 1)
        End If
    End Select
Next
End With
End Sub

Alles zou moeten werken behalve item2 uit vraag2, maar oogjes beginnen dicht te vallen dus eerst wat slapen nu.
 
Hallo Warme bakkerje,

Bedankt voor je hulp.
De code is al heel dicht bij de oplossing.

Uitkomst1 is perfect.

Bij uitkomst2 is het bijbehorende bedrag uit bron2 niet ingevuld .
In veld E2 moet staan 200, in e4 400 en in e5 450.

Hetgeen in uitkomst3 moet komen te staan heb Ik (waarschijnlijk) niet duidelijk genoeg geformuleerd. De bedoeling is dat in uitkomst3 alleen de nummers (en het bedrag) moet komen te staan die slechts eenmaal voorkomen in bron2 en niet voorkomen in bron1( dit laatste had ik niet goed beschreven).

En nog bedankt dat je een deel van je nacht opofferde om het script te schrijven!

Met vriendelijke groet,

Theo
 
Een schoonheidsprijs wordt het zeker niet, maar hij doet wat jij verwacht (hoop ik)
Code: 
Sub test()
lRowBr1 = Sheets("Bron1").Range("A" & Rows.Count).End(xlUp).Row
lRowBr2 = Sheets("Bron2").Range("A" & Rows.Count).End(xlUp).Row
With Sheets("Bron1")
For Each cl In .Range("A2:A" & lRowBr1)
    Select Case WorksheetFunction.CountIf(.Range("A2:A" & lRowBr1), cl.Value)
    Case 1
        If WorksheetFunction.CountIf(Sheets("Bron2").Range("A2:A" & lRowBr2), cl.Value) = 1 Then
            cl.Resize(, 4).Copy Sheets("Uitkomst1").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Sheets("Uitkomst1").Range("A" & Rows.Count).End(xlUp).Offset(, 4) = Sheets("Bron2").Columns(1).Find(cl.Value, , xlValues, xlWhole).Offset(, 1).Value
        End If
    Case Is > 1
        lAant = WorksheetFunction.CountIf(Sheets("Bron1").Range("A2:A" & lRowBr1), cl.Value) - 1
        If cl = Sheets("Uitkomst2").Range("A" & Sheets("Uitkomst2").Rows.Count).End(xlUp) Then GoTo Vervolg
        With Sheets("Bron1")
            .AutoFilterMode = False
            .Columns(1).AutoFilter 1, cl
            .AutoFilter.Range.Offset(1).SpecialCells(12).Copy Sheets("Uitkomst2").Range("A" & Rows.Count).End(xlUp).Offset(1)
            .AutoFilterMode = False
        End With
        With Sheets("Bron2")
            .AutoFilterMode = False
            .Columns(1).AutoFilter 1, cl
            .AutoFilter.Range.Offset(1, 1).Copy Sheets("Uitkomst2").Range("A" & Rows.Count).End(xlUp).Offset(-lAant, 4)
            .AutoFilterMode = False
        End With
    End Select
Vervolg:
Next
End With
With Sheets("Bron2")
For Each cl In .Range("A2:A" & lRowBr2)
    Select Case WorksheetFunction.CountIf(.Range("A2:A" & lRowBr2), cl.Value)
    Case 1
        If WorksheetFunction.CountIf(Sheets("Bron1").Range("A2:A" & lRowBr1), cl.Value) = 0 Then
            cl.Resize(, 2).Copy Sheets("Uitkomst3").Range("A" & Rows.Count).End(xlUp).Offset(1)
        End If
    Case Is > 1
        If WorksheetFunction.CountIf(Sheets("Bron1").Range("A2:A" & lRowBr1), cl.Value) = 0 Then
            cl.Copy Sheets("Uitkomst2").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Sheets("Uitkomst2").Range("A" & Rows.Count).End(xlUp).Offset(, 4) = cl.Offset(, 1)
        End If
    End Select
Next
End With
End Sub
 
Hallo Warme Bakkertje!

Geniaal!!

Ik heb de macro getest op 2 bestanden van circa 1500 regels en de conclusie is uitkomst1 en uitkomst3 voor 100% kloppen en uitkomst2 voor 99%.

In uitkomst2 gaat het volgende nog niet helemaal goed:

-Kolom b,c en d werden in de 1e versie wel gevuld en in de 2e versie niet
-Indien in bron2 een nummer 2 of meer keer voorkomt en in bron1 slechts 1x dan volgt er geen kopieeractie (deze mogelijkheid doet zich overigens in het testbestand niet voor.

Met vriendelijke groet,

Theo
 
Bekijk je bestanden en denk eerst goed na wat er nu eigenlijk moet/kan gebeuren.
Eerst had je je derde vraag niet volledig geformuleerd, nu kom je weer met iets af dat zich niet in het voorbeeldbestand voordoet en waarover jij met geen letter gesproken hebt.
Op die manier kan ik wel bezig blijven nietwaar. Wat zal het volgende zijn als ik dit opgelost krijg ?
Met iemand helpen heb ik geen enkel probleem, maar dan krijg ik wel graag vanaf het begin het volledige plaatje zodat ik niet telkens overnieuw moet beginnen.
 
Hallo warme bakkertje,

Je hebt gelijk. Natuurlijk moet de vraagstelling voor 100% kloppen en duidelijk zijn voor degene die de code moet schrijven.

Het heeft niet met opzet plaatsgevonden. Iets voor 100% formuleren in een begrijpelijke zin is niet gemakkelijk dat kom ik zelf ook vaker tegen als ik een handleiding bestudeer, teksten lees e.d..
De te schrijven code moet toegepast worden op grote bestanden. In het testbestand heb ik getracht alle mogelijke combinaties onder te brengen. Dat is helaas niet gelukt. Bij het controleren van de uitkomsten van de grote bestanden werd dat pas zichtbaar. Nogmaals excuses.

Met vriendelijke groet,

Theo

Excuses voor de overlast

Met vriendelijke groet,

Theo
 
Code: 
Sub test()
lRowBr1 = Sheets("Bron1").Range("A" & Rows.Count).End(xlUp).Row
lRowBr2 = Sheets("Bron2").Range("A" & Rows.Count).End(xlUp).Row
With Sheets("Bron1")
For Each cl In .Range("A2:A" & lRowBr1)
    Select Case WorksheetFunction.CountIf(.Range("A2:A" & lRowBr1), cl.Value)
    Case 1
        If WorksheetFunction.CountIf(Sheets("Bron2").Range("A2:A" & lRowBr2), cl.Value) = 1 Then
            cl.Resize(, 4).Copy Sheets("Uitkomst1").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Sheets("Uitkomst1").Range("A" & Rows.Count).End(xlUp).Offset(, 4) = Sheets("Bron2").Columns(1).Find(cl.Value, , xlValues, xlWhole).Offset(, 1).Value
        End If
    Case Is > 1
        lAant = WorksheetFunction.CountIf(Sheets("Bron1").Range("A2:A" & lRowBr1), cl.Value) - 1
        If cl = Sheets("Uitkomst2").Range("A" & Sheets("Uitkomst2").Rows.Count).End(xlUp) Then GoTo Vervolg
        With Sheets("Bron1")
            .AutoFilterMode = False
            .Columns(1).AutoFilter 1, cl
            .AutoFilter.Range.Offset(1).SpecialCells(12).Copy Sheets("Uitkomst2").Range("A" & Rows.Count).End(xlUp).Offset(1)
            .AutoFilterMode = False
        End With
        With Sheets("Bron2")
            .AutoFilterMode = False
            .Columns(1).AutoFilter 1, cl
            .AutoFilter.Range.Offset(1, 1).Copy Sheets("Uitkomst2").Range("A" & Rows.Count).End(xlUp).Offset(-lAant, 4)
            .AutoFilterMode = False
        End With
    End Select
Vervolg:
Next
End With
With Sheets("Bron2")
For Each cl In .Range("A2:A" & lRowBr2)
    Select Case WorksheetFunction.CountIf(.Range("A2:A" & lRowBr2), cl.Value)
    Case 1
        If WorksheetFunction.CountIf(Sheets("Bron1").Range("A2:A" & lRowBr1), cl.Value) = 0 Then
            cl.Resize(, 2).Copy Sheets("Uitkomst3").Range("A" & Rows.Count).End(xlUp).Offset(1)
        End If
    Case Is > 1
        If WorksheetFunction.CountIf(Sheets("Bron1").Range("A2:A" & lRowBr1), cl.Value) = 0 Then
            cl.Copy Sheets("Uitkomst2").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Sheets("Uitkomst2").Range("A" & Rows.Count).End(xlUp).Offset(, 4) = cl.Offset(, 1)
        End If
        If WorksheetFunction.CountIf(Sheets("Bron1").Range("A2:A" & lRowBr1), cl.Value) = 1 Then
            cl.Copy Sheets("Uitkomst2").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Sheets("Uitkomst2").Range("A" & Rows.Count).End(xlUp).Offset(, 4) = cl.Offset(, 1)
        End If
    End Select
Next
End With
End Sub
 
Hallo Warme Bakkertje,

Van harte bedankt voor je hulp. Dit script is de oplossing.
Dank je wel!

Met vriendelijke groet,

Theo
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan