Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim a, F As Worksheet, F1 As Worksheet, F2 As Worksheet
Dim ncol%, t, t1, ub&, t2, doublon1(), doublon2(), deb&, i&, x, j&, k%
a = Array("Feuil3", "Feuil4", "Feuil5") 'CodeNames des feuilles
If IsError(Application.Match(Sh.CodeName, a, 0)) Then Exit Sub
Set F = Feuil3: Set F1 = Feuil4: Set F2 = Feuil5
ncol = 3 'nombre de colonnes du tableau Source A
Application.ScreenUpdating = False
Feuil1.Cells.Copy F1.Cells
Feuil2.Cells.Copy F2.Cells
F1.UsedRange.Sort F1.Columns(1), Header:=xlYes 'tri
F2.UsedRange.Sort F2.Columns(1), Header:=xlYes 'tri
F.Rows("3:" & F.Rows.Count).Delete 'RAZ
F2.UsedRange.Offset(1).Copy F.[A3].Offset(, ncol)
t = F.UsedRange.Offset(1)
t1 = F1.UsedRange.Resize(, ncol): ub = UBound(t1)
t2 = F2.UsedRange.Resize(UBound(t))
ReDim a(1 To UBound(t), 1 To ncol)
ReDim doublon1(1 To UBound(t1), 1 To 1)
ReDim doublon2(1 To UBound(t2), 1 To 1)
deb = 2
For i = 2 To UBound(t)
x = t(i, ncol + 1)
If x <> t(i - 1, ncol + 1) Then 'évite les doublons
For j = deb To ub
If j < ub Then If t1(j + 1, 1) = t1(j, 1) Then _
doublon1(j + 1, 1) = "Doublon"
If x = t1(j, 1) Then
For k = 1 To ncol
a(i - 1, k) = t1(j, k)
Next k
t1(j, 1) = Empty
t2(i, 1) = Empty
deb = j + 1
Exit For
End If
Next j
Else
doublon2(i, 1) = "Doublon"
End If
Next i
F.[A3].Resize(i - 1, ncol) = a
F1.UsedRange.Resize(, ncol) = t1
F2.UsedRange = t2
With F1.UsedRange.Columns(1).Offset(, F1.UsedRange.Columns.Count)
.Value = doublon1
.Font.Bold = True 'gras
End With
With F2.UsedRange.Columns(1).Offset(, F2.UsedRange.Columns.Count)
.Value = doublon2
.Font.Bold = True 'gras
End With
'--suppression des cellules vides en colonne A---
F.UsedRange.Offset(1).Sort F.Columns(1), Header:=xlYes 'tri
F1.UsedRange.Sort F1.Columns(1), Header:=xlYes 'tri
F2.UsedRange.Sort F2.Columns(1), Header:=xlYes 'tri
On Error Resume Next
F.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
F1.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
F2.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub