Dubbele item? Hoe beide verwijderen

[uaebroc]

Bekijk bijlage voorbeeld.xlsx

Wie kan me verder helpen

Ik heb een voorraad lijst in excel van twee bedrijven.

Kolom A is bedrijf
Kolom B is artikel

Ik wil alleen overhouden de artikelen die uniek zijn bij het bedrijf (dus de groene cellen)

Als beide bedrijven het artikel nr. hebben moeten ze in geheel verwijderen uit de excel.



Het betreft +/- 15.000 regels dus moet een foefje vinden maar kom niet verder bij ontdubbelen blijft er 1 staan natuurlijk maar bij mij moeten ze allemaal weg.

wie kan me helpen?

 

[AlexCEL]

Welkom hier.

Allereerst een tip voor de toekomst: plaats een representatief EXCEL voorbeeldbestand. Het is geen photoshop forum hier. Het voorbeeld helpt om snel een juist antwoord te vinden, zonder te hoeven gokken of noodzaak tot overtypen.

 

[uaebroc]

Welkom hier.

Allereerst een tip voor de toekomst: plaats een representatief EXCEL voorbeeldbestand. Het is geen photoshop forum hier. Het voorbeeld helpt om snel een juist antwoord te vinden, zonder te hoeven gokken of noodzaak tot overtypen.

Sorry, snap hem ik heb het voorbeeld nu bijgevoegd

 

[AlexCEL]

Geen probleem.. Nog een tip: gebruik niet de QUOTE knop, maar druk op "reageer op bericht" of typ onderin bij "snel reageren".

Zoeken van unieke nummers die bij slechts één bedrijf voorkomen kan met:

E2: =ALS.FOUT(INDEX(B:B;KLEINSTE(ALS(AANTAL.ALS($B$2:$B$8;$B$2:$B$8)=1;RIJ($B$2:$B$8);9E+99);RIJ()-RIJ($E$1)));"")

Opmerkingen:
1. Het betreft matrixformules, dat wil zeggen afsluiten met Control+Shift+Enter na invoeren/wijzigen.
2. Formule doortrekken naar beneden.
3. Uitgangspunt is dat elk artikelnummer slechts 1x per bedrijf voorkomt.
4. Het bijbehorende bedrijf wordt identiek opgezocht door B:B te vervangen door A:A.

Zie bijlage.

 

[uaebroc]

Ik denk dat ik vanavond weer wat kan leren, paar testjes gedaan volgens mij krijg ik het wel zo onder de knie.

Straks met het grote bestand gaan proberen.

Alvast erg bedankt

 

[Ginger]

Een matrix functie op 15.000 regels? Gaat dat goed?

 

[Ginger]

Het lijkt mij ook wel wenselijk om de oude waardes te bewaren. Deze procedure zet op een tweede Tab alle unieke waardes en laat de tabel op Tab 1 ongemoeid...

Sub VerwijderDubbelen()
Dim q2()
Dim q3 As Range

    q1 = Sheets(1).Cells(1).CurrentRegion
    Set q3 = Sheets(1).Cells(1).CurrentRegion.Columns(2)
    
    For i = 2 To UBound(q1, 1)
        If WorksheetFunction.CountIf(q3, q1(i, 2)) = 1 Then
            ii = ii + 1
            ReDim Preserve q2(1 To 2, 1 To ii)
            q2(1, ii) = q1(i, 1)
            q2(2, ii) = q1(i, 2)
        End If
    Next i
    
    Sheets(2).Cells(1).Resize(UBound(q2, 2), 2) = Application.Transpose(q2)
    
End Sub

 

[uaebroc]

Ginger,

Werkt! met matrixformule was denk ik echt te groot bestand.
Maar met VBA lukt het dus wel (nog nooit eerder gedaan).

Nog een vraagje nu wil ik twee extra kolommen die er achter staan ook op het tweede tabblad zetten.

Hoe kan ik dat doen?

Bekijk bijlage voorbeeld2.xlsx

 

[uaebroc]

Kan iemand me nog verder helpen?

Ik wil graag met dit VBA script de twee extra kolommen ook tonen op tabblad 2, heb veel geprobeerd maar krijg het niet voor elkaar

 

[Ginger]

Had je post op donderdag gemist. Ik zal morgen ff voor je kijken.

 

[uaebroc]

Super bedankt! alvast zou je me echt mee helpen :thumb:

 

[Ginger]

uaebroc, hierbij je gevraagde uitbreiding. Ik heb 'm iets flexibeler gemaakt. Als je nu in je grote tabel nog een kolom zou toevoegen, wordt die automatisch meegepakt. Verkleinen kan overigens ook... ;-)
Daarnaast de regels nog wat voorzien van commentaar zodat je er wellicht iets van kan leren.

Sub VerwijderDubbelen()
Dim q2()
Dim q3 As Range

    q1 = Sheets(1).Cells(1).CurrentRegion  ' dit is de complete tabel die onderzocht moet worden op dubbelen
    Set q3 = Sheets(1).Cells(1).CurrentRegion.Columns(2)  ' dit zijn de artikelnummers uit die tabel
    
    For i = 2 To UBound(q1, 1) ' doorloop alle records uit de complete tabel
        If WorksheetFunction.CountIf(q3, q1(i, 2)) = 1 Then  ' als het artikelnummer dubbel is, doe niets. Anders...
            ii = ii + 1  ' hou een recordteller bij voor de nieuw op te bouwen tabel
            ReDim Preserve q2(1 To UBound(q1, 2), 1 To ii) ' en vergroot die tabel elke keer dat het nodig is
            For x = 1 To UBound(q2, 1)  ' haal uit elke kolom van het record het gegeven op
                q2(x, ii) = q1(i, x)
            Next x
        End If
    Next i
    
    Sheets(2).Cells(1).Resize(UBound(q2, 2), UBound(q2, 1)) = Application.Transpose(q2) ' schrijf de unieke records weg naar sheet 2
    
End Sub

 

[uaebroc]

Super bedankt! :thumb:

De uitleg helpt ook zeker om het e.e.a. te leren

Top!