Sup doublon et + en VBA

[Bat]

Bonjour

Je cherche une macro qui vas supprimer dans ma colonne G toute les lignes où il y à des doublons. Mais le truc en + c'est que 'tout doit disparaître'. Pour comprendre voir l'exemple suivant où le résultat est uniquement Test 2 et Test 4 car ce sont les seuls qui n'taient pas en doublon.

Tableau initial :
G
Test 1
Test 1
Test 2
Test 1
Test 1
Test 3
Test 1
Test 3
Test 1
Test 4

RESULTAT :
G
Test 2
Test 4


Merci de votre aide !

 

[Bat]

Re

J'ai trouvée cette macro qui m'élimine le doublon. Or moi c'est les doublons et l'original (du doublon) que je souhaite effacer. Donc cette macro ne vas pas !!!



Sub Princ()
'Macro permettant de supprimer les doublons

Dim Plage As Range
Dim T
'Indiquer les références de la plage sélectionnée
'à adapter en fonction des extractions
Set Plage = Range('A2:J502')

'Indiquer le numéro de la colonne dans laquelle les doublons apparaîssent
T = Doublons(Plage.Value, 7)
If IsArray(T) Then
T = InverseTab(T, 1)
With Plage
.Clear
.Cells(1, 1).Resize(UBound(T), UBound(T, 2)) = T
End With
Else: MsgBox T
End If
End Sub


Function Doublons(T, ColT As Byte) 'Zon
Dim I&, J&, K&, Tablo As New Collection
Dim Temp()
For I = LBound(T, 1) To UBound(T, 1)
On Error Resume Next
Tablo.Add T(I, ColT), CStr(T(I, ColT))
If Err = 0 Then
ReDim Preserve Temp(1 To UBound(T, 2), 1 To J + 1)
For K = 1 To UBound(Temp)
Temp(K, J + 1) = T(I, K)
Next K
J = J + 1
End If
Next I
Doublons = IIf(J > 0, Temp, 'Pas de doublons')
End Function
Function InverseTab(T, Optional Base As Byte = 0)
Dim Temp(), I&, J&
ReDim Temp(Base To UBound(T, 2), Base To UBound(T))
For I = LBound(T, 2) To UBound(T, 2)
For J = LBound(T) To UBound(T)
Temp(I, J) = T(J, I)
Next J
Next I
InverseTab = Temp
End Function

 

[Hervé]

bonjour bat

une proposition, les doublons sont en colonne A:

Sub Bouton1_QuandClic()
Dim c As Range
Dim plage As Range
Dim i As Integer

Application.ScreenUpdating = False

Set plage = Range('a1:a' & Range('a65536').End(xlUp).Row)

For Each c In plage
        If Application.WorksheetFunction.CountIf(plage, c) > 1 Then
                c.Interior.ColorIndex = 6
        End If
Next c

For i = plage.Count To 1 Step -1
        If Cells(i, 1).Interior.ColorIndex = 6 Then Rows(i).Delete
Next i
End Sub

salut

 

[BAT]

Bonjour Hervé et merci !

C'est ça mais ça ne supprime pas les ligne ? Ca les mets en surbrillance !

 

[Hervé]

Re bat

si si ca supprime les lignes.

voir en pièce jointes.

salut [file name=BAT.zip size=7495]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/BAT.zip[/file]

 

[Jacques87]

Bonsoir Bat

Voici quelquechose de plus simple qui de plus répond à ta question [file name=doublons_20060124175456.zip size=9175]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/doublons_20060124175456.zip[/file]

 

[Jacques87]

Oups Hervé
Bien le bonjour
Je te prie de bien vouloir m'excuser de t'avoir bousculé
Amitiés

PS : je viens de regarder de façon plus approfondie ton code. Dis donc tu es un petit futé : tu repères les indésirables, tu les marques au rouge et après tu les détruis. Mais dis donc ça ne s'appelle pas 'une rafle' cette méthode (lol)

Message édité par: Jacques87, à: 24/01/2006 18:02

 

[Bat]

Impec !

Merci à vous deux pour ces beaux exemples !

a bientôt !

 

[Hervé]

re bat, salut jacques



oui, c'est une méthode de sioux.

c'est un procédé que j'utilise souvent ca évite de s'embarquer dans des boucles de folies.

je m'en va voir ta proposition.

salut

 

[pat1545.]

Salut,

avec VBA bien sur moiu j'utilise ce code que j'ai mis dans la clic droit de ma souris (il faut que la colonne immédiatement à droite soit libre):
Patrick

' debut de code

Option Explicit

Sub ValUniquesACote() ' PlageSrc As Range, CellDest As Range)
'Extrait les valeurs uniques d'une colonne et les renvoie
'dans une autre, à partir de CellDest tiré d'un code de F. Signonneau (pense-je)
Dim Arr1, Elt, Arr2(), Coll As New Collection, i As Integer
'If PlageSrc.Columns.Count > 1 Then Exit Sub ' Mais possible sur 2 colonnes
'Arr1 = PlageSrc.Value
Arr1 = Selection.Value
Dim Colo
Dim line
Dim err
Colo = Selection.Column
line = Selection.Row
For Each Elt In Arr1
On Error Resume Next
Coll.Add Elt, CStr(Elt)
If err.Number = 0 Then
ReDim Preserve Arr2(1 To Coll.Count)
Arr2(Coll.Count) = Elt
End If
On Error GoTo 0
Next
For i = 1 To Coll.Count
If IsEmpty(Cells(line, Colo + 1)) Then
Cells(line + i, Colo + 1).Value = Coll.Item(i)
Else
MsgBox ('cellule voisine non vide')
MsgBox Coll.Item(i)
End If
Next
Application.Transpose (Arr2)
End Sub

Sub MenuCell() 'pour mettre ds le clic droit
Dim Ctrl
For Each Ctrl In Application.CommandBars('Cell').Controls
Ctrl.Enabled = True
Next
With Application.CommandBars('Cell').Controls.Add(msoControlButton)
.Caption = 'Unique à droite'
.BeginGroup = True
.FaceId = 252
.OnAction = 'ValUniquesACote'
End With
End Sub


Sub Efface_ClicDroit() ' retirer du click droit
On Error Resume Next
Application.CommandBars('Cell').Controls('Unique à droite').Delete
End Sub

' fin de code ( attention aux lignes coupées)