Bonjour,
Voici un code pour appareiller deux classeurs et ne conserver que les éléments identiques. On commence par recopier le contenu d'un classeur A et dans classeur B dans un classeur C. Et le reste se passe sous le classeur C. C'est lui qui porte la macro. Tu peux t'inspirer du code:
Option Base 1
Sub AntiDoublons()
Dim iLRA%, iLRM%, I%, j%, Nb%, a%
Dim k As Double
Dim Y As Boolean
Dim TabloA(), TabloM()
Dim WbA As Workbook, WbM As Workbook
Dim WsA As Worksheet, WsM As Worksheet
Set WbA = ThisWorkbook
Set WbM = ThisWorkbook
Set WsA = WbA.Worksheets(4)
Set WsM = WbM.Worksheets(4)
Nb = 1
Application.ScreenUpdating = True
Sheets("Feuil3").Select
Cells.Select
Selection.ClearContents
Selection.ClearFormats
'dernieres celulles de A dans mon classeur A
iLRA = Columns("A:A").Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
'dernieres celulles de N dans mon classeur B
iLRM = Columns("N:N").Find("*", Range("N1"), , , xlByRows, xlPrevious).Row
'juste un calcul pour mon besoin
a = 2
Do While a < iLRM
Worksheets("Saisie").Range("L" & a).Formula = "=J" & a & "-K" & a
a = a + 1
Loop
'la feuille saisie contient les deux sources colonne A et N respectivement du classeur A et B, et se trouve sur le classeur C
Sheets("Saisie").Activate
'Tableaux des données présentes en A et en M
TabloA() = WsA.Range("A1:A" & iLRA)
TabloM() = WsM.Range("N1:N" & iLRM)
'Détermination des absents/présents
k = 1
For I = 2 To UBound(TabloA)
For j = 2 To UBound(TabloM)
'Si égalité alors on pose un drapeau
If TabloM(j, 1) = TabloA(I, 1) Then
Y = True
'1ere copie: issue du fichier RELANCE (A:C) ( mon classeur A )
Sheets("Saisie").Activate
Range(WsM.Cells(I, 1), WsM.Cells(I, 3)).Copy
Sheets("Feuil3").Activate
Range("A" & k).Select
ActiveSheet.Paste
'2eme copie issue: du fichier Grand Livre (D:N) ( mon classeur B )
Sheets("Saisie").Activate
Range("D" & j & ":N" & j).Copy
'On colle tout ca dans le classeur C
Sheets("Feuil3").Activate
Range("D" & k).Select
ActiveSheet.Paste
k = k + 1
'1ere cellule "A" en vert
Sheets("Saisie").Activate
WsM.Cells(I, 1).Interior.ColorIndex = 4
Nb = Nb + 1
Exit For
End If
Next
'Si pas trouvé alors on colorie celulle "A" en rouge
If Not Y Then WsM.Range("A" & I).Interior.ColorIndex = 3
Y = False
Next
'quelques renommage de feuilles
Sheets("Saisie").Activate
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Feuil3").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Sheets("Saisie").Name = "TEMP"
Sheets("Feuil3").Name = "Saisie"
Set WbA = Nothing
Set WbM = Nothing
Set WsA = Nothing
Set WsM = Nothing
MsgBox "Traitement terminé ! Nb de correspondances:" & Nb & " sur " & iLRA & " lignes"
Application.ScreenUpdating = True
End Sub
Bon courage. Si tu as besoin d'aide écris-moi.
