Résolu Comparer 2 colonnes dans deux fichiers avec macro

BigA

XLDnaute Nouveau
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

XLDnaute Occasionnel
Bonjour,

La macro ci-dessous doit être lancée avec les 2 fichiers ouverts.
(adapter au besoin les noms de classeurs et de feuilles).
VB:
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

XLDnaute Nouveau
Bonjour,

La macro ci-dessous doit être lancée avec les 2 fichiers ouverts.
(adapter au besoin les noms de classeurs et de feuilles).
VB:
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
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas