Rijen met zelfde waarde in cel verwijderen in Exel

Status
Niet open voor verdere reacties.
A

Amber55

Gebruiker
Lid geworden
12 mei 2018
Berichten
12
ik heb in Excel een lijst met gegevens van 5500 producten verdeeld in 4 kolommen. De producten die er dubbel in staan moeten verwijderd worden. De producten die overblijven wil ik in dit overzicht hebben. Kolom D staat artikelnummer. Wie kan mij helpen met een VBA code voor het verwijderen van rijen met dezelfde waarden in kolom D?
 
kan zo met klassieke opties, zonder vba, bv uitgebreid filter ofwel verwijderen duplicaten
 
Dit?

Code: 
ActiveSheet.Range("$A$1:$D$440000").RemoveDuplicates Columns:=4, Header:=xlNo

Getallen in Range kun je uiteraard veranderen...
Groet, Opa Maarten
 
cow18 zei:
kan zo met klassieke opties, zonder vba, bv uitgebreid filter ofwel verwijderen duplicaten
Klik om te vergroten...

De optie verwijderen duplicaten is bekend maar dat verwijdert slechts een regel. In mijn lijst moeten beide regels verwijderd worden. Anders gezegd als cel 1 en cel 2 van kolom D dezelfde waarde heeft dan moeten de rijen 1 en 2 verwijderd worden. Sorry voor onvolledige inleiding,
 
mvdvlist zei:
Code: 
ActiveSheet.Range("$A$1:$D$440000").RemoveDuplicates Columns:=4, Header:=xlNo

Getallen in Range kun je uiteraard veranderen...
Groet, Opa Maarten
Klik om te vergroten...

Bedankt voor je reactie maar met deze code verwijdert slechts een regel. In mijn lijst moeten beide regels verwijderd worden. Anders gezegd als cel 1 en cel 2 van kolom D dezelfde waarde heeft dan moeten de rijen 1 en 2 verwijderd worden. Sorry voor onvolledige inleiding,
 
Zie bijlage en voer code hsv uit.
 

Bijlagen

  • Amber55.xlsb
    13,9 KB · Weergaven: 36
ik begrijp dit niet, hoe werkt dat met die J1:J2 ?:eek:
 
Advancedfilter evalueert de formule op kolom D, hetzelfde als een filter op een waarde.
Maar wat J1 erbij doet, heb ik geen idee van, die cel is namelijk leeg.
Het zal wel niet met minder dan twee cellen willen (de filtermanier op kolomkop en waarde).
 
heb je hier uitgebreidere informatie over ?
Of heb je dit op goed geluk opgenomen met de recorder ?
Ik sta hier met open mond naar te kijken.
 
@cow18, Volgens mij heb ik deze techniek ooit ergens gevonden en hier ook wel vaker toegepast. Dus echt nieuw is het niet. Het is een krachtige methode om geavanceerd te filteren zonder een hulpkolom. (komt het eigenlijk op neer)
Macro-opnames werken niet echt lekker met het geavanceerde filter. In een ander draadje heb ik laten zien dat je ook een nieuw bestand kan openen en daarin de gefilterde data kan wegschrijven. Probeer maar eens met de macro-recorder.:)

Hier staat wel iets uitgelegd maar is denk ik niet geheel het antwoord op jouw vraag.
 
De formule toepassing in combinatie met advancedfilter is hier ooit eens op Helpmij.nl geplaatst door iemand.
Ik zag het toentertijd voor het eerst, maar kan helaas niet op de naam komen wie het bericht plaatste.

Het is geen regelmatige codeschrijver die ermee kwam, dat is het enige wat me is bijgebleven (en de manier natuurlijk).
 
Het is een knap stukje, zal het proberen te onthouden.
Het doet me een beetje denken aan de werking van een matrixformule, een beetje analoog.
 
bedankt, ik kijk het na
 
De vogende code doet wat ik bedoel. Hij zoekt op dubbelen in 2 kolommen en plaatst de niet dubbelen in nieuwe tabel op nieuw tabblad. Heb de code aangetroffen op dit Forum. Nu ontbreekt nog de aanpassing voor 4 kolommen.


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
 
Beetje vreemd nietwaar?

Je start een vraag; je krijgt reactie.
Vervolgens kom je met een gevonden code die een aanpassing nodig heeft en er wordt niet over de aangereikte reactie gereageerd.

Plaats het bestand waarom het draait.
 
kan veel eenvoudiger met een dictionary, maar inderdaad die uitgebreide filter was toch subliem.
 
Bij deze de dictionary methode.

Code: 
Sub hsv_2()
Dim sv, i As Long, s0 As String, sd As Object
With Cells(1).CurrentRegion
sv = .Value
Set sd = CreateObject("scripting.dictionary")
   For i = 1 To UBound(sv)
       sd(sv(i, 4)) = Application.Index(sv, i)
    If InStr(s0, sv(i, 4)) Then sd.Remove sv(i, 4)
        s0 = s0 & "|" & sv(i, 4)
  Next i
   .ClearContents
   .Resize(sd.Count, 4) = Application.Index(sd.items, 0, 0)
End With
End Sub
 
ik had eerder voor deze optie gekozen ipv. instr. Dan kijk je naar de volledige string
Code: 
If UBound(Filter(Split(s0, "|"), sv(i, 4), 1)) <> -1 Then
 
Of:
Code: 
Sub hsv_3()
Dim sv, i As Long, sd As Object
With Cells(1).CurrentRegion
sv = .Value
Set sd = CreateObject("scripting.dictionary")
   For i = 1 To UBound(sv)
     If InStr(Join(sd.keys), Join(Application.Index(sv, i))) Then
        sd.Remove Join(Application.Index(sv, i))
      Else
        sd(Join(Application.Index(sv, i))) = Application.Index(sv, i)
   End If
  Next i
   .ClearContents
   .Resize(sd.Count, 4) = Application.Index(sd.items, 0, 0)
End With
End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan