Comparer les éléments de 2 fichiers

[J-Charles]

Bonjour à tous,

Il y a environ 15 jours j'ai sollicité votre aide pour m'aider à créer une macro permettant de comparer 2 colonnes dans 2 fichiers différents (Classeur1 & Classeur2).
MichelXLD a eu la gentillesse de me répondre et ses lignes m'ont été d'un grand secours.
J'ai modifié sa macro en rajoutant une ligne afin de colorer les cellules des éléments communs aux 2 fichiers, en l'occurence dans la colonne du fichier Classeur2.xls 🙁Cible.Interior.ColorIndex=45).
Le problème est que si dans la colonne (de Classeur2.xls) un élément X commun aux 2 fichiers est répété plusieurs fois, seul le premier détecté dans la colonne sera coloré.
En revanche le message du résultat donnant la liste des éléments en commun est ok, car il ne répète pas plusieurs fois l'élément.

Sub ComparaisonColonnes()

    Dim Wb1 As Workbook, Wb2 As Workbook
    Dim Cell As Range, Cible As Range
    Dim Tableau()
    Dim X As Byte, Y As Byte, Z As Byte, i As Byte
    Dim Resultat As String, FirstAddress As String
 
     'Définit les classeurs (supposés ouverts)
    Set Wb1 = Workbooks("Classeur1.xls")
    Set Wb2 = Workbooks("classeur2.xls")
 
    'Boucle sur les données de la feuille active dans le premier classeur
    For Each Cell In Wb1.ActiveSheet.Range("A10:A100")
        Z = 0
    
    'Effectue la recherche dans le deuxième classeur
    With Wb2.ActiveSheet.Range("A10:A100")
        Set Cible = .Find(Cell, LookIn:=xlValues, lookAt:=xlWhole)
        'Si une donnée est trouvée
        If Not Cible Is Nothing Then
        Cible.Interior.ColorIndex = 45
        FirstAddress = Cible.Address
            'Cible.Interior.ColorIndex = 45
            X = X + 1
            ReDim Preserve Tableau(1 To 2, 1 To X)
            Do
                Workbooks("Classeur2.xls").Activate
                Sheets(1).Activate
                Cible.Select
                Z = Z + 1
                Set Cible = .FindNext(After:=ActiveCell)
            'Recherche d'autres données identiques
            Loop While Not Cell Is Nothing And _
            Cible.Address <> FirstAddress
            'Alimente le tableau de résultat
            Tableau(1, X) = Cible
            Tableau(2, X) = Z
            Y = Y + Z
        End If
    End With
Next Cell
 
    'Affiche le résultat de la comparaison
    If Y = 0 Then
        MsgBox "Aucune donnée commune entre les 2 fichiers."
        Exit Sub
    End If

    Resultat = "Il y a des données communes entre les deux fichiers:" _
        & Chr(10) & "(cellules colorées orange)" _
        & Chr(10) & Chr(10)
    For i = LBound(Tableau(), 2) To UBound(Tableau(), 2)
        Resultat = Resultat & Tableau(1, i) & Chr(10)
    Next i
 
    MsgBox Resultat
    

End Sub

Pourriez vous m'aider à modifier la macro, afin que tous les élements communs aux 2 fichiers se colorent (fond de cellule) dans la colonne du fichier Classeur2.xls.
Je vous remercie d'avance.

 

[J-Charles]

Re : Comparer les éléments de 2 fichiers

Bonjour à tous,

J'ai réussi a trouver un petit bout de code que j'ai modifié et qui répond à mon besoin. Je vais écrire ces quelques lignes (sans aucune prétention car je ne suis pas trés calé) au cas où cela pourrait intéressé quelqu'un.

Sub ComparaisonColonnes()

Dim Collection1 As New Collection, Collection2 As New Collection
Dim Cellule1 As Range, Cellule2 As Range
Dim Element1 As Object, Element2 As Object
Dim OrigineClasseur1 As Workbook, OrigineClasseur2 As Workbook


    Application.ScreenUpdating = False
    Set OrigineClasseur1 = ActiveWorkbook  'Fichier 1
    
    'Nomme la dernière cellule non vide de la colonne A du fichier 1
    Sheets(1).Activate
    Range("A65536").End(xlUp).Select
    Selection.Name = "DerLigne1"
    
    'Nomme la dernière cellule non vide de la colonne A du fichier 2
    Windows(2).Activate
    Set OrigineClasseur2 = ActiveWorkbook  'fichier 2
    Sheets(1).Activate
    Range("A65536").End(xlUp).Select
    Selection.Name = "DerLigne2"
    
    'Test les éléments communs entre les colonnes A des 2 fichiers A et B 
et colore la cellule (dans la colonne A du fichier 1)
    OrigineClasseur1.Sheets(1).Activate
    For Each Cellule1 In Range("A1:DerLigne1")
        Collection1.Add Cellule1
    Next Cellule1

    OrigineClasseur2.Activate
    Sheets(1).Activate
    For Each Cellule2 In Range("A1:DerLigne2")
        Collection2.Add Cellule2
    Next Cellule2
    
    For Each Element1 In Collection1
    For Each Element2 In Collection2
        If Element1 = Element2 Then
            Element1.Interior.ColorIndex = 45
            Exit For
        End If
    Next Element2
    Next Element1
        
   End Sub

Ce n'est sans doute pas du grand art mais cela m'a bien rendu service.
Bonne journée à tous