[COLOR=DarkSlateGray][B]Option Explicit
Sub toto(ancien$, nouveau$, destination$)
Dim af, nf, Laf&, Caf&, Lnf&, Cnf&, Lex&, tmp$, i&, oColl As New Collection
Dim Naf As Worksheet, Nnf As Worksheet, Nex As Worksheet, Tobj As Object
Set Naf = Sheets(ancien)
Set Nnf = Sheets(nouveau)
Set Nex = Sheets(destination)
Set Tobj = xtrct(Naf)
If Not Tobj Is Nothing Then af = Tobj.Value
Set Tobj = xtrct(Nnf)
If Not Tobj Is Nothing Then nf = Tobj.Value
Set Tobj = xtrct(Nex)
With Application: .ScreenUpdating = 0: .Calculation = -4135: .EnableEvents = 0: End With
If Not Tobj Is Nothing Then Tobj.Clear
Set Tobj = Nothing
Select Case (VarType(af) = 0) + 2 * (VarType(nf) = 0)
Case 0: [COLOR=DarkOrange]'af et nf non vides[/COLOR]
If UBound(af, 2) = UBound(nf, 2) Then
Lex = 1
For Laf = 1 To UBound(af, 1)
tmp = af(Laf, 1)
For Lnf = 1 To UBound(nf, 1)
If tmp = nf(Lnf, 1) Then Exit For
Next Lnf
If Lnf > UBound(nf, 1) Then [COLOR=DarkOrange]'Enregistrement supprimé[/COLOR]
Lex = Lex + 1
Naf.Cells(1, 1).Offset(Laf, 0).EntireRow.Copy destination:=Nex.Cells(1, 1)(Lex)
Nex.Cells(1, 1)(Lex).Resize(1, UBound(af, 2)).Font.Color = RGB(255, 0, 0)
End If
Next Laf
For Lnf = 1 To UBound(nf, 1)
tmp = nf(Lnf, 1)
For Laf = 1 To UBound(af, 1)
If tmp = af(Laf, 1) Then Exit For
Next Laf
If Laf > UBound(af, 1) Then [COLOR=DarkOrange]'Enregistrement ajouté[/COLOR]
Lex = Lex + 1
Nnf.Cells(1, 1).Offset(Lnf, 0).EntireRow.Copy destination:=Nex.Cells(1, 1)(Lex)
Nex.Cells(1, 1)(Lex).Resize(1, UBound(nf, 2)).Font.Color = RGB(64, 192, 0)
Else
For Cnf = 2 To UBound(nf, 2)
If af(Laf, Cnf) <> nf(Lnf, Cnf) Then oColl.Add Cnf
Next Cnf
If oColl.Count > 0 Then [COLOR=DarkOrange]'Enregistrement modifié[/COLOR]
Lex = Lex + 1
With Nex.Cells(1, 1)(Lex)
Nnf.Cells(1, 1).Offset(Lnf, 0).EntireRow.Copy destination:=.Cells
For i = 1 To oColl.Count
.Offset(0, oColl(i) - 1).Font.Color = RGB(0, 0, 255)
Next i
End With
Set oColl = Nothing
End If
End If
Next Lnf
Else
MsgBox "Les enregistrements ne sont pas comparables."
End If
Case -1: [COLOR=DarkOrange]'af vide et nf non vide[/COLOR]
With Nex.[A2].Resize(UBound(nf, 1), UBound(nf, 2)): .Value = nf: .Font.Color = RGB(64, 192, 0): End With
Case -2: [COLOR=DarkOrange]'af non vide et nf vide[/COLOR]
With Nex.[A2].Resize(UBound(af, 1), UBound(af, 2)): .Value = af: .Font.Color = RGB(255, 0, 0): End With
Case -3: [COLOR=DarkOrange]'af et nf vides[/COLOR]
MsgBox "Il n'y a rien à traiter"
End Select
Nex.Activate
Set Nex = Nothing
Set Nnf = Nothing
Set Naf = Nothing
With Application: .EnableEvents = 1: .Calculation = -4105: .ScreenUpdating = 1: End With
End Sub
Private Function xtrct(f As Worksheet) As Object
Dim Tobj As Object
With f
Set Tobj = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, 1).End(xlToRight).Column))
End With
If Tobj.Rows.Count > 1 Then Set xtrct = Tobj.Offset(1, 0).Resize(Tobj.Rows.Count - 1)
End Function[/B][/COLOR]
