Vérifier si une ligne est similaire à une autre ligne sur toute la liste

Bonjour,

Je voudrais un peu d'aide je suis bloqué sur une partie dans un projet.

Voila le contexte j'ai actuellement un fichier contenant des données (une grande liste de data) parmi ses données, nous avons deux type de cas des données presque similaire (que l'on considère comme des données liées dans le projet) et des données différents que j'aimerai séparer dans deux feuilles (Feuil_sim et Feuil_diff).

Pour pouvoir savoir si deux lignes sont liées (je compare 3 cellules de la ligne x à 3 cellules de la ligne x+1) si les données correspondant alors je les copie dans la feuille Feuil_sim et la boucle continue.

Le problème c'est que j'ai réussi à faire une vérification ligne par ligne et non dans la liste entière, mais dans le cas si les données d'une ligne x et de la ligne x+1 ne sont pas similaire je veux que la ligne x soit comparer à la ligne x+3 et ainsi de suite jusqu'a trouver une similaire sinon elle sera envoyé dans la feuille Feuil_diff

Public Sub S1()

Dim lg As Long
Dim i As Long

lg = Sheets("Donnees").Range("A" & Rows.Count).End(xlUp).Row

    For i = 2 To lg

        'Dans le cas ou les données ligne x et les données lignes x+1 correspondent
        If (Sheets("Donnees").Range("D" & i).Value = Range("C" & i + 1).Value) And (Sheets("Donnees").Range("F" & i).Value = Range("F" & i + 1).Value) And (Sheets("Donnees").Range("A" & i).Value = Range("A" & i + 1).Value) Then

            Sheets("Donnees").Range("A" & i).Resize(, 5).Copy Destination:=Sheets("Feuil_sim").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Sheets("Donnees").Range("A" & i + 1).Resize(, 5).Copy Destination:=Sheets("Feuil_sim").Range("G" & Rows.Count).End(xlUp).Offset(1)

            'vu que les deux lignes sont copiées on passe à la ligne suivant donc deux sauts de ligne avec le next
            i = i + 1

        'Dans le cas ou les données ligne x et les données lignes x+1 SONT DIFFERENT
        ElseIf (Sheets("Feuil3").Range("D" & i).Value <> Range("C" & i + 1).Value) And (Sheets("Feuil1").Range("F" & i).Value <> Range("F" & i + 1).Value) And (Sheets("Sheet1").Range("A" & i).Value <> Range("A" & i + 1).Value) Then

 'Je suis coincé ici :(           

    Next

End Sub

J'arrive pas à trouve la bonne méthode pour vérifier de ligne en ligne jusqu'a la dernière ligne dans le deuxième cas ou les ligne x et x+1 correspondent comme ça x et comparer à x+1,x+2....x+n (la dernière ligne dans le cas ou la correspondance je la ligne x se situe dans la dernière ligne)

Je sais pas si mes explications sont clair ou pas, vu que je suis nouveau dans la programmation VBA je n'arrive à trouver le bon acheminement.

Je vous ai rajouter un exemple avec un tableau simplifier (vu que le fichier de base est confidentiel avec deux cas exemple (si ça peut aider à la compréhension)

Je vous remercie d'avance pour votre aide.

Bonjour

Un essai à tester. Te convient-il ?

Bye !

Parfait ça fonctionne, merci beaucoup , j'aimerai bien comprendre le code (j'ai essayé de voir de mon côté mais )

Option Explicit

Dim tablo, tabloR(), fD As Worksheet, fL As Worksheet
Dim i&, iR&, ln&, j&, k&, flag&

Sub LignesLiees()

    tablo = Range("A1").CurrentRegion
    ReDim tabloR(1 To UBound(tablo, 1), 1 To UBound(tablo, 2))
    k = 0
    For i = 2 To UBound(tablo, 1) - 1
        flag = 0
        For ln = i + 1 To UBound(tablo, 1)
            If tablo(i, 1) = tablo(ln, 1) _
                    And tablo(i, 4) = tablo(ln, 3) _
                    And tablo(i, 6) = tablo(ln, 6) Then
                If flag = 0 Then
                    For j = 1 To UBound(tablo, 2)
                        tabloR(k + 1, j) = tablo(i, j)
                        flag = 1
                    Next j
                    k = k + 1
                End If
                For j = 1 To UBound(tablo, 2)
                    tabloR(k + 1, j) = tablo(ln, j)
                Next j
                k = k + 1
            End If
        Next ln
    Next i
    Sheets("Lignes liees").Range("A3").CurrentRegion.Offset(1, 0).ClearContents
    Sheets("Lignes liees").Range("A4").Resize(k, UBound(tablo, 2)) = tabloR
    Sheets("Lignes liees").Activate
End Sub

C'est possible d'implémenter un code, dans un cas ou une ligne correspond à aucune autre ligne pour la mettre dans une autre feuille (C'est surement dans un Else mais vu que je comprend pas le code je vois pas le faire)

Ici pour la ligne 10 et 11

Je vais essayer faire des tests pour comprendre le code

Mais merci encore pour ce que vous avez fait c'est incroyable !

Désolé gmb, j'ai parlé un peu trop vite , j'ai du coup adapter le code que tu m'a fourni j'ai interpréter, les informations et ajouter les cellules spécifiques à vérifier dans la liste.

J'ai essayé ça sur le tableau confidentiel en adaptant les informations à vérifier mais j'en ai 3106 le début ça compile bien mais à moment j'ai une erreur

Option Explicit

Dim tablo, tabloR(), fD As Worksheet, fL As Worksheet
Dim i&, iR&, ln&, j&, k&, flag&

Sub LignesLiees()

    tablo = Sheets("DATA_1").Range("A1").CurrentRegion
    ReDim tabloR(1 To UBound(tablo, 1), 1 To UBound(tablo, 2))
    k = 0
    For i = 2 To UBound(tablo, 1) - 1
        flag = 0
        For ln = i + 1 To UBound(tablo, 1)
            'J'ai donc modifier les cellules à verfier suivant la ligne ici j'ai 4 conditions au total
            If tablo(i, 1) = tablo(ln, 1) _
                    And tablo(i, 5) = tablo(ln, 4) _
                    And tablo(i, 11) = tablo(ln, 11) _
                    And tablo(i, 21) = tablo(ln, 21) Then
                If flag = 0 Then
                    For j = 1 To UBound(tablo, 2)
                        tabloR(k + 1, j) = tablo(i, j)
                        flag = 1
                    Next j
                    k = k + 1
                End If
                For j = 1 To UBound(tablo, 2)
                    ' Mais j'ai une erreur ici la condition ne correspond pas
                    'j'ai k = 3106 (le nb max de line) et j = 1 et ln = 2293 j =1
                    tabloR(k + 1, j) = tablo(ln, j)
                Next j
                k = k + 1
            End If
        Next ln
    Next i
    'Ici j'ai donc renseigner la feuille avec les cellule ou copier ses fameux données liées
    Sheets("DATA_2").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
    Sheets("DATA_2").Range("A2").Resize(k, UBound(tablo, 2)) = tabloR
    Sheets("DATA_2").Activate
End Sub

voici l'erreur :

c'est au niveau de la ligne :

Je suis totalement perdu.

Bonjour

Nouvelle version

Bye !

Merci pour avoir pris le temps d'annoter les explications, vous avez une idées pour l'erreur que j'ai ? je n'arrive pas à comprendre pourquoi pour une cinquantaine de ligne ça marche du tonnerre mais si le range du tableau est plus grand ça ne marche pas j'ai la fameuse erreur au niveau :

Merci encore

...mais si le range du tableau est plus grand ça ne marche pas

Joins- moi le fichier pour lequel tu as le problème...

Bye !

Désoler pour le retard j'ai du crée un fichier similaire pour que tu puisse m'aider

Nouvelle version

Bye !

Merci beaucoup vous m'avez résolu un grand problème, du coup s'était quoi le problème ? pourquoi à partir d'une certaine ligne cela ne correspondais pas ?

s'était quoi le problème ?

C'était que le résultat des lignes liées comporte plus de lignes que le nombre de lignes du tableau de DATA_1

Il faut donc dimentionner tabloR avec un nomble de lignes plus grand. Je l'ai doublé :

ReDim tabloR(1 To UBound(tablo, 1) * 2, 1 To UBound(tablo, 2))    'tablo des lignes liées

ok ?

Bye !

Je vous remercie