Si même valeurs, données colonne d'un classeur vers un autre

Bonjour,

Il y a un petit moment, on m'a gentiment procuré un VBA pour aller récupérer un classeur et ainsi comparer les valeurs de la colonne A avec le classeur actuellement ouvert. Si il trouve une similitude avec le classeur ouvert de base, alors le VBA récupère les couleur des lignes similaires du classeur récupéré pour les remettre dans le classeur déjà ouvert. Mon besoin serait que en plus de remettre les couleurs sur les lignes, si le VBA trouve des valeurs dans la colonne "COMMENTAIRE" dans le classeur récupéré, qu'il les copies dans le classeur déjà ouvert dans la même colonne pour les bonnes lignes. Vous trouverez ci-dessous le VBA pour mieux comprendre. Je vous remercie d'avance !

Sub Comparateur_Fich()
Dim ThisWbk As Workbook, WbkComp As Workbook
Dim ThisSh As Worksheet, ShComp As Worksheet
Dim LesNoms As Object
Dim Cel As Range, Plg As Range, C As Range
Dim NewFich, Ke
Dim DerLig As Long
Application.ScreenUpdating = False
Set LesNoms = CreateObject("Scripting.Dictionary")
Set ThisWbk = ThisWorkbook
Set ThisSh = ThisWbk.Sheets("JUILLET") 'Nom du fichier actuellement ouvert (le dernier)(Nommer l'onglet de la même façon que le fichier)
ChDir ThisWbk.Path
Application.ScreenUpdating = False
NewFich = Application.GetOpenFilename("Fichiers Xlsx,*.xlsx")
    If Not NewFich = False Then
        Set WbkComp = Workbooks.Open(NewFich)
    End If
Set ShComp = WbkComp.Sheets("JUIN") 'Nom du fichier à aller chercher (nommer l'onglet de la même façon que le fichier)
With ShComp
    DerLig = .Cells(Rows.Count, "A").End(xlUp).Row
    Set Plg = .Range("A2:A" & DerLig)
    For Each Cel In Plg
        If Cel.Value <> "" Then LesNoms(Cel.Value) = Cel.Interior.ColorIndex
    Next Cel
End With
With ThisSh
    .Cells.Interior.ColorIndex = -4142
    For Each Ke In LesNoms.Keys
        Set C = .Columns(1).Find(Ke)
        If Not C Is Nothing Then
            C.Resize(1, 22).Interior.ColorIndex = LesNoms(Ke)
        End If
    Next Ke
End With
WbkComp.Close False
End Sub

Je précise que si c'est plus simple pour vous, ça peut être un VBA à part, cela me va tout autant ! :)

Bonjour

Une solution vaguement testée :

à la place de :

    For Each Cel In Plg
        If Cel.Value <> "" Then LesNoms(Cel.Value) = Cel.Interior.ColorIndex
    Next Cel

mettre :

  For Each cel In Plg
      If cel.Value <> "" Then LesNoms(cel.Value) = Array(cel.Interior.ColorIndex, cel.Offset(0, 4).Value)
  Next cel

et à la place de :

        If Not C Is Nothing Then
            C.Resize(1, 22).Interior.ColorIndex = LesNoms(Ke)
        End If

mettre un truc du genre (à adapter) :

  For Each k In LesNoms.keys
    i = i + 1
    Range("J" & i).Value = LesNoms.Item(k)(1)
    Range("J" & i).Interior.ColorIndex = LesNoms.Item(k)(0)
  Next k

En fait tu récupère en même temps la couleur et le commentaire dans un array() puis tu n'as plus qu'à coller chaque champ de l'array dans la bonne cellule