Supprimer Doublon avec conditions VBA

[Guillaumeg3]

Bonjour à Tous

J'ai une problématique pour recouper 2 fichiers pour ma base de données.

Voir fichier exemple joint.

J'aimerai pouvoir supprimer un doublons en fonction de certains critères.
Dans mon fichier les lignes à supprimer sont en rouge mais j'aimerai que l'ID soit reporté dans la ligne restante.
Comme le montre le fichier, Le nom ou marque peuvent être écrit différemment.
Mon idée est si les 2 ou 3 premières lettres (ou chiffre) du Nom sont égales et si les 2ou 3 première lettres du Constructeurs sont égales ainsi que la date de construction -> supprimer la ligne où la case "TYPE" est vide et copier l'ID dans la ligne non supprimée.

Merci infiniment de votre aide

 

[vgendron]

Hello
code à essayer..

Sub recouper()
Dim tablo() As Variant

With ActiveSheet
    tablo = .UsedRange.Offset(1, 0).Value
End With

For i = LBound(tablo, 1) To UBound(tablo, 1) - 1
    If Left(tablo(i, 2), 4) Like Left(tablo(i + 1, 2), 4) And Left(tablo(i, 3), 4) Like Left(tablo(i + 1, 3), 4) And tablo(i, 6) = tablo(i + 1, 6) Then
        tablo(i + 1, 1) = tablo(i, 1)
        tablo(i, 1) = ""
    End If
Next i
With ActiveSheet
    .Range("A2").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
    .Range("A2").Resize(UBound(tablo, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With

End Sub

 

[Guillaumeg3]

Merci beaucoup VGENDRON! C'est un bon début mais j'ai une erreur sur la ligne 7.
J'ai complété ma feuille test en la complexifiant un peu mais le code n'a plus l'air de prendre et supprime la mauvaise ligne.

Bien à toi

 

[vgendron]

Essai avec ceci..

Sub recouper()
Dim tablo() As Variant

NbCarac = InputBox("Donnez le nombre de caractères à prendre en compte pour les correspondances")

With ActiveSheet
    tablo = .UsedRange.Offset(1, 0).Value
End With

FusionDone = False
Encore = False
For i = LBound(tablo, 1) To UBound(tablo, 1) - 1
    If Left(tablo(i, 2), NbCarac) Like Left(tablo(i + 1, 2), NbCarac) And Left(tablo(i, 3), NbCarac) Like Left(tablo(i + 1, 3), NbCarac) And tablo(i, 6) = tablo(i + 1, 6) Then
        'tablo(i + 1, 1) = tablo(i, 1)
       ' tablo(i, 1) = ""
        FusionDone = True
        For j = LBound(tablo, 2) To UBound(tablo, 2)
            If tablo(i, j) = "" Xor tablo(i + 1, j) = "" Then
                tablo(i + 1, j) = tablo(i, j) & tablo(i + 1, j)
            Else
                tablo(i + 1, j) = tablo(i + 1, j)
            End If
        Next j
        tablo(i, 1) = ""
    ElseIf tablo(i, 1) = "" Then
        tablo(i, 1) = "NON fusionné"
        Encore = True
    End If
       
Next i
With ActiveSheet
    If FusionDone Then
        .Range("A2").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
        .Range("A2").Resize(UBound(tablo, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        For i = 2 To .UsedRange.Rows.Count
            If .Range("A" & i) = "NON fusionné" Then .Range("A" & i) = ""
        Next i
    End If
End With
If Encore Then MsgBox ("Il reste des lignes à fusionner, diminuez le nombre de caractères")

End Sub

 

[Guillaumeg3]

Merci Encore Vgendron pour te pencher sur mon problème.

C'est bien pensé le système de caractère mais si je m'est 1 caractère, cela supprime aussi les bonnes lignes car il ne prend pas en compte la case Année pour les différencié ligne 7 et 8

La ligne 11 et 12 quand c'est des chiffres n'est pas reconnu.

Merci à toi

 

[vgendron]

La ligne 11 et 12 quand c'est des chiffres n'est pas reconnu.

si c'est reconnu.. essai en inversant les deux lignes avant de lancer la macro. tu vas voir
normalement, dans le dernier code. l'ordre des deux lignes n'est plus important

le nombre de caractères n'influence pas pour la date. parce que le test regarde les deux années complètes.

 

[Guillaumeg3]

Je teste mais chez moi cela ne marche pas, il inverse aussi les lignes à supprimer.

Je passe de 3 caractères puis 2 puis 1 mais cela m'efface les bonnes lignes aussi....

 

[vgendron]

Bonjour
Chez moi. pas de problème... voir PJ
à noter au passage: le code. il faut le mettre dans un module standard. pas dans la feuille..
dans ton dernier fichier.. la macro "Recouper" existe 2 fois.. dans un module (celle qui doit etre lancée) et dans le code de la feuille...

 

[Guillaumeg3]

Bonjour
Chez moi. pas de problème... voir PJ
à noter au passage: le code. il faut le mettre dans un module standard. pas dans la feuille..
dans ton dernier fichier.. la macro "Recouper" existe 2 fois.. dans un module (celle qui doit etre lancée) et dans le code de la feuille...

Bonjour vgendron, Merci en effet je m'en était aperçu dans la soirée. J'ai essayé de bidouiller mais rien y fait j'ai toujours ce problème entre la ligne 7 et 8. on dirait qu'il inverse le code pour récupérer les données dans les bonnes colonnes.
En effet si j'inverse l'ordre cela marche je pourrais pas le faire manuellement sur mon fichier de 140000 lignes dont le 3/4 sont des doublons.
Mon problème c'est que les données surlignées en rouge ont généralement des données incomplètes dans la case modèle et c'est cette dernière qui reste. En faisant le teste sur le fichier et en faisant un tri de A a Z je me retrouve avec le meme problème sur d'autres lignes. Lle code supprime les mauvaises lignes meme si ces dernières ont des infos completes.

J'ai essayé de bidouillé mais rien n'y fait...

Merci encore à toi pour ton aide

Edit, Si je supprime le contenu de la case modèle dans la ligne en rouge (8), la valeur du modèle dans la bonne ligne reste.