Discussion :

[Stéphane_MAN]

Bonjour à tous,

Comment supprimer une valeur en double ( une valeur double spécifique).

Exemple j'ai deux cellules, une avec la mention PARISBONDY, une autre avec la mention BONDYPARIS pour moi c'est un doublon et je voudrais en supprimer une mais je sais comment m'y prendre avez-vous une astuce svp ?

Cordialement,

[Invité]

Bonjour,

Je ne pense pas à cette possibilité (sauf si une autre colonne propose dans cette exemple la ville "Paris")
car c'est de l'anagramme , et dans l'avenir qui sait qu'il n'y aura pas d'autre données qui sont des anagrammes mais non doublons

Je laisse la main à des experts

[Invité]

Bonjour,

En VBA, à tester :

Le principe est de balayer les caractères composant une chaine et d'affecter les caractères du numéro 1 au caractère en cours dans une variable ChainePartielle et de mettre le complément de la chaine dans une variable ChaineComplementaire. Il faut ensuite balayer l'aire à tester et regarder si les deux chaines s'y trouvent sans que ce soit la chaîne de départ...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 
 
Function SensRetour(ByVal AireATester As Range, ByVal Chaine As String) As String
 
Dim CelluleTest As Range
Dim ChainePartielle As String, ChaineComplementaire As String
Dim I As Integer
 
    SensRetour = ""
    For I = Len(Chaine) To 1 Step -1
        ChainePartielle = Mid(Chaine, 1, I)
        ChaineComplementaire = Mid(Chaine, I + 1)
        For Each CelluleTest In AireATester
          If InStr(1, CelluleTest, ChainePartielle, vbTextCompare) > 0 And CelluleTest <> Chaine Then
            If InStr(1, CelluleTest, ChaineComplementaire, vbTextCompare) > 0 Then
               SensRetour = CelluleTest
               Exit Function
            End If
          End If
        Next CelluleTest
    Next I
 
End Function
 
Sub TestSensRetour()
 
    MsgBox SensRetour(Sheets("Feuil1").Range("A2:A10"), "PARISBONDY")
 
End Sub

Dans ce code, on ne teste qu'une fois le cas...

[Invité]

Dans cette solution, ce sont toutes les cellules trouvées qui sont mises en jaune et filtrées à la fin le cas échéant :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
 
Option Explicit
 
Private NombreOccurrences As Long
 
Sub SensRetour(ByVal AireATester As Range, ByVal Chaine As String)
 
Dim CelluleTest As Range
Dim ChainePartielle As String, ChaineComplementaire As String
Dim I As Integer
 
    For I = Len(Chaine) To 1 Step -1
        ChainePartielle = Mid(Chaine, 1, I)
        ChaineComplementaire = Mid(Chaine, I + 1)
        For Each CelluleTest In AireATester
          If InStr(1, CelluleTest, ChainePartielle, vbTextCompare) > 0 And CelluleTest <> Chaine Then
            If InStr(1, CelluleTest, ChaineComplementaire, vbTextCompare) > 0 And Len(CelluleTest) = Len(Chaine) Then
               CelluleTest.Interior.Color = RGB(255, 255, 0)
               NombreOccurrences = NombreOccurrences + 1
            End If
          End If
        Next CelluleTest
    Next I
 
End Sub
 
Sub TestSensRetour()
 
Dim AireDuTest As Range, CelluleDuTest As Range
 
    NombreOccurrences = 0
    Set AireDuTest = Sheets("Feuil1").Range("A2:A10")
    With AireDuTest
         .Interior.ColorIndex = xlNone
         For Each CelluleDuTest In AireDuTest
             SensRetour AireDuTest, CelluleDuTest
         Next CelluleDuTest
 
         If NombreOccurrences > 0 Then
             .AutoFilter Field:=1, Criteria1:=RGB(255, 255, 0), Operator:=xlFilterCellColor
         End If
    End With
 
    Set AireDuTest = Nothing
 
End Sub

[Invité]

Bonjour,

T'es toujours bloqué en gare de Bondy ?