Comparer 2 colonnes dans deux fichiers avec macro

[BigA]

Bonsoir à tous,

Je suis débutant en VBA et j'ai besoin de votre aide pour un problème que je rencontre depuis quelques jours.

J'ai deux fichiers, Fichier1 et Fichier2, je voudrai comparer la colonne C du Fichier1 avec la colonne C du Fichier2.
Si une correspondance est trouvée alors la ligne du Fichier1 doit être remplacée par la ligne contenant la correspondance du Fichier2.

Précision: La colonne C du Fichier1 va contenir 1500 lignes dans quelques jours et la fonction match doit être exécutée en boucle de C2 à la dernière ligne.

Est-ce que quelqu'un peut m'aider pour concocter ce code ?

Merci d'avance
Bien cordialement,
BigA

 

[frangy]

Bonjour,

La macro ci-dessous doit être lancée avec les 2 fichiers ouverts.
(adapter au besoin les noms de classeurs et de feuilles).

Sub Comparer()
Dim WbS As Workbook, WbC As Workbook
Dim WsS As Worksheet, WsC As Worksheet
Dim PlageC As Range, PlageS As Range, Cel As Range, C As Range
    Set WbC = Workbooks("Fichier1")
    Set WbS = Workbooks("Fichier2")
    Set WsC = WbC.Worksheets("Check PC MEP-APA")
    Set WsS = WbS.Worksheets("Sheet1")
    Set PlageC = WsC.Range("C2:C" & WsC.Range("C" & Rows.Count).End(xlUp).Row)
    Set PlageS = WsS.Range("C2:C" & WsS.Range("C" & Rows.Count).End(xlUp).Row)
    Application.ScreenUpdating = False
    For Each Cel In PlageC
        Set C = PlageS.Find(Cel, , xlValues, xlWhole)
        If Not C Is Nothing Then
            C.EntireRow.Copy Cel.EntireRow
            Cel.EntireRow.Font.ColorIndex = 3
        End If
    Next Cel
    Application.ScreenUpdating = True
End Sub

Cordialement.

 

[BigA]

Bonjour,

La macro ci-dessous doit être lancée avec les 2 fichiers ouverts.
(adapter au besoin les noms de classeurs et de feuilles).

Sub Comparer()
Dim WbS As Workbook, WbC As Workbook
Dim WsS As Worksheet, WsC As Worksheet
Dim PlageC As Range, PlageS As Range, Cel As Range, C As Range
    Set WbC = Workbooks("Fichier1")
    Set WbS = Workbooks("Fichier2")
    Set WsC = WbC.Worksheets("Check PC MEP-APA")
    Set WsS = WbS.Worksheets("Sheet1")
    Set PlageC = WsC.Range("C2:C" & WsC.Range("C" & Rows.Count).End(xlUp).Row)
    Set PlageS = WsS.Range("C2:C" & WsS.Range("C" & Rows.Count).End(xlUp).Row)
    Application.ScreenUpdating = False
    For Each Cel In PlageC
        Set C = PlageS.Find(Cel, , xlValues, xlWhole)
        If Not C Is Nothing Then
            C.EntireRow.Copy Cel.EntireRow
            Cel.EntireRow.Font.ColorIndex = 3
        End If
    Next Cel
    Application.ScreenUpdating = True
End Sub

Cordialement.

Bonjour Frangy,

Merci pour ton aide, c'est exactement ce qu'il me fallait.

Bien cordialement,
BigA