Supprimer données supperflues excel Résolu/Fermé

Question

Bonjour, 

http://www.cijoint.fr/cjlink.php?file=cj201012/cijoRhp9ZI.xls

Voici le fichier de travail.
en fait il faut procéder à un filtre sur la colonne 3 et regarder chaque élément présent dans la liste.
ensuite quand le premier élément de la colonne 3 est visible, on regarde en colonne 1 les 7 premiers caractères.
S'ils sont communs, on supprime les lignes se trouvant sous la pemière ligne de données (voir exemple, ce sont les lignes grisées)
S'ils ne sont pas communs on ne fait rien et on regarde le second élément et ainsi de suite.

le filtre sur la colonne 3 est pour simplifier l'explication mais dans la macro il est inutile qu'il apparaisse, c'est le test sur chaque ligne qui est important.

En espérant que vous aurez une solution

Configuration: Windows XP / Internet Explorer 6.0

anthony · Answer

PS. la macro présente était mon essai, vous pouvez la supprimer

michel_m · Answer

Bonjour,

J'avais fait la macro et l'ordi m'a fait un caprice! $@+#!!!

je te propose un truc demain dans le courant de la matinée

anthony · Answer

ok merci

michel_m · Answer

Bonjour,

essaies cette macro

Option Base 1
Sub supprimer_gauche()
Dim Tablo
Dim Derlig As Integer, Lig As Integer, Cptr As Integer
Dim Ref As String

ReDim Tablo(Cptr + 1) As Integer
Lig = 2
With Sheets("STATUS_XLS 1 ")
    Derlig = .Range("C1000").End(xlUp).Row
    Ref = .Cells(Lig, 3) & .Cells(Lig, 1)
    For Lig = 3 To Derlig
        If Ref = Left(.Cells(Lig, 3) & .Cells(Lig, 1), Len(Ref)) Then
            Cptr = Cptr + 1
            ReDim Preserve Tablo(Cptr)
            Tablo(Cptr) = Lig
         Else
            Ref = .Cells(Lig, 3) & .Cells(Lig, 1)
        End If
    Next

    Application.ScreenUpdating = False
    For Cptr = UBound(Tablo) To 1 Step -1
        .Rows(Tablo(Cptr)).Delete
    Next
End With
End Sub



Tu dis, car j'ai eu encore pas mal de pb avec l'ordi ce matin  d'où 3 heures supplémentaires à essayer de rester zen quand m^me :-)

anthony · Answer

BOnjour,

ça fonctionne parfaitement.
je verrai pour modifier le code que tu as fait pour supprimer les actions sur la colonne 3.
c'est l'utilisateur qui m'a indiqué qu'il filtrait sur la colonne 3 pour mieux voir les redondances sur la colonne 1 mais avec la macro ce filtre n'est nécessaire.
la colonne 1 doit être consultée et les lignes ayant les 7 premiers caractères communs avec la précédente doit être effacée.

j'avais essayé avec 
Dim val1 As String*7, val2 As String*7
mais ensuite je ne savais pas comment faire.

en tous les cas merci beaucoup michel_m

anthony · Answer

Bonjour michel_m

la macro ne fonctionne pas totalement, j'ai des données qui perdurent, exemple :
U042236, U042236C, U042236D
ou encore U044226, U044226B, U044226C, U044226D

michel_m · Answer

Bonjour,

teste le nombre de caractères (fonction XL nbcar) des données qui perdurent: il y a peut-être des espaces qui trainent avant ou après tes données 
si oui, modifie
Ref = .Cells(Lig, 3) & .Cells(Lig, 1)
en
Ref =trim(.Cells(Lig, 3)) & trim(.Cells(Lig, 1))

si non je vois pas

anthony · Answer

bizarre je ne trouve pas mon dernier commentaire et le tien.
pour dire qu'il n'existe aucun espace, aucun caractère caché

anthony · Answer

en fait je pense avoir compris le soucis.
généralement tu as 7 caractères sur la première ligne par exemple et sur la seconde tu vas avoir le 8ème caractère qui va être ajouté pour différencier de la ligne précédente.
ex : J033AJD, J033AJDA, J033AJDB etc --> J033AJDA et J033AJDB seront bien effacées

en fait la macro ne fonctionne pas dans le cas où ta première ligne à déjà 8 caractères et les suivantes aussi
ex : U023052R, U023052S, U023052T --> aucune n'est effacée

michel_m · Answer

bonjour, 

le temps de retrouver les classeurs avec la macro et je regarde en fin de pm mais il faut que je me remette le pb en t^te !

michel_m · Answer

re,

essaies cette modif (un peu au jugé!)
...
With Sheets("STATUS_XLS 1 ")
    Derlig = .Range("C1000").End(xlUp).Row
    Ref = .Cells(Lig, 3) & Left(.Cells(Lig, 1), 7)
    For Lig = 3 To Derlig
        If Ref = .Cells(Lig, 3) & Left(.Cells(Lig, 1), 7) Then
...
Tu dis...

anthony · Answer

il me met une erreur 1004

anthony · Answer

.Rows(Tablo(Cptr)).Delete

anthony · Answer

je dois avoir une merdouille, je vais voir

anthony · Answer

Hello
on m'avait donné jusqu'à la fin de l'année pour mettre au point une macro pour supprimer les doublons et ce matin je me suis penché sur la question.
finalement j'ai réussi à pondre un code qui fonctionne nickel.
Ca peut tjs servir

Sub sup_doublons()
Dim i As Integer, k As Integer, var As Integer

For i = 1 To Range("A65536").End(xlUp).Row
    var = 0
    nom1 = Range("A" & i).Value
    nom3 = Range("C" & i).Value
    For k = i + 1 To Range("A65536").End(xlUp).Row
        nom2 = Range("A" & k).Value
        nom4 = Range("C" & k).Value
        If nom3 = nom4 Then
        If Left(nom2, 7) = Left(nom1, 7) Then
            var = 1
            Rows(k).Delete
            k = k - 1
        End If
        End If
    Next k
Next i
End Sub