Duid de dubbels aan in kleur

[Marky76]

In bijlage heb je een eenvoudig lijstje met nummer, met daarin dubbels.
Nu had ik graag een formule die de dubbels aanduid in het lijstje en een formule
die de dubbels wist.

 

[Wigi]

Dubbele:

* Aanduiden: voorwaardelijke opmaak met formule dat AANTAL.ALS groter is dan 1.
* Deleten: zie Data > Uitgebreide filter.

Wigi

 

[Marky76]

Dubbels

Begrijp het niet. Kan je het in het bestandje voordoen.
Ik ben in voorwaardelijke opmaak gegaan heb formule gekozen, dan
AANTAL.ALS maar wat geef ik dan in als bereik en achter ; wat geef ik daar dan in.

Ik doe iets verkeerd.

Groeten,

 

[richard1970]

Hoi Marky,

Zie bijlage.

Richard

 

[Marky76]

Dubbels

Bedank Wigi en Richard.

Kan je met een formule het volgende bekomen.
Dus alle dubbels die nu aangeduid staan daarvoor zou ik graag in kolom B, het woord dubbel zien verschijnen.
En kan ik met een formule, waarschijnlijk in VBA, alle dubbels wissen behalve 1 die ik dan aanduid??

Inmiddels al bedankt, kan al sneller verder werken.

Groeten,

 

[jpvs]

Voor de formule kun je dit gebruiken:

=ALS(AANTAL.ALS(A:A; A1)>1;"Dubbel";"")

zet dit in cel B1 en doorvoeren naar beneden.


Macro gevonden voor kolom A :

Sub DeleteRows()
Dim i As Integer, j As Integer
Dim AantalRijen
Dim EersteInhoud As Variant, VolgendeInhoud As Variant

AantalRijen = Worksheets(1).UsedRange.Rows.Count
For i = 1 To AantalRijen - 1
EersteInhoud = Worksheets(1).Cells(i, 1)
If EersteInhoud <> "" Then
For j = i + 1 To AantalRijen
VolgendeInhoud = Worksheets(1).Cells(j, 1)
If VolgendeInhoud = EersteInhoud Then
Worksheets(1).Cells(j, 1).Interior.ColorIndex = 4
Worksheets(1).Cells(i, 1).Interior.ColorIndex = 4
End If
Next
End If
Next
End Sub


Public Sub DeleteDuplicateRows()
'
' This macro deletes duplicate rows in the selection. Duplicates are
' counted in the COLUMN of the active cell.

Dim Col As Integer
Dim r As Long
Dim C As Range
Dim N As Long
Dim V As Variant
Dim Rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Col = ActiveCell.Column

If Selection.Rows.Count > 1 Then
Set Rng = Selection
Else
Set Rng = ActiveSheet.UsedRange.Rows
End If

N = 0
For r = Rng.Rows.Count To 1 Step -1
V = Rng.Cells(r, 1).Value
If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
Rng.Rows(r).EntireRow.Delete
N = N + 1
End If
Next r

EndMacro:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub


Pierre

 

[Wigi]

Mark

wat wil je eigenlijk doen:

- de dubbele getallen allemaal deleten?
- van de dubbele getallen telkens nog 1 "exemplaar" laten staan?

Dat is belangrijk om de macro juist op te stellen.

Wigi

 

[Marky76]

Dubbels kleuren en wissen

Pierre,

Alles werkt perfect! Bedankt.

Groeten, Mark.