Bonjour
Essaie ce code à placer dans un module
en tete de module tu mets
option base 1
Sub Sans_double()
' HARMONISER 2 LISTES SANS DOUBLON AVEC DES ARRAYS
' TRAITEMENT DE 2 COLONNES AVEC TRI CROISSANT
' LES 2 COLONNES SONT DANS UNE MÊME FEUILLE
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim Y&, Z&, I&, J&, N&, Flag As Boolean
Dim CombArray() As Variant, Tempo As Variant, Cll As Range
Dim Plage1 As Range, Plage2 As Range, Sortie As Range
With Feuil3
Y = Range('A65536').End(xlUp).Row
Z = Range('B65536').End(xlUp).Row
'RESET DU TRAITEMENT PRECEDENT
Range('F3:F10000').ClearContents
'DÉFINITION DES PLAGES À TRAITER
Set Plage1 = Range('A3:A' & Y)
Set Plage2 = Range('B3:B' & Z)
Set Sortie = Range('F3')
' DIMENSIONNEMENT DU TABLEAU A 2 DIMENSIONS
N = Plage1.Cells.Count + Plage2.Cells.Count
ReDim CombArray(N, 2)
' CHARGEMENT DES 2 LISTES DE VALEURS DANS LE TABLEAU.
For Each Cll In Plage1
I = I + 1
CombArray(I, 1) = Cll.Value
Next Cll
For Each Cll In Plage2
I = I + 1
CombArray(I, 1) = Cll.Value
Next Cll
' BUBBLE SORT TRI CROISSANT DU TABLEAU DES VALEURS.
Flag = False
While Not Flag
Flag = True
For I = 1 To UBound(CombArray) - 1
If CombArray(I, 1) > CombArray(I + 1, 1) Then
Tempo = CombArray(I, 1)
CombArray(I, 1) = CombArray(I + 1, 1)
CombArray(I + 1, 1) = Tempo
Flag = False
Exit For
End If
Next I
Wend
' IDENTIFICATION DES DOUBLONS DANS LE TABLEAU . TRUE = DOUBLONS
'LA DEUXIEME DIMENSION DU TABLEAU FLAGUE LES DOUBLONS EN TRUE
CombArray(1, 2) = False
For I = 1 To UBound(CombArray) - 1
If CombArray(I, 1) = CombArray(I + 1, 1) Then
CombArray(I + 1, 2) = True
Else
CombArray(I + 1, 2) = False
End If
'Debug.Print CombArray(I, 2)
Next I
' RESTITUTION DE LA LISTE SANS DOUBLON DANS LA ZONE SORTIE
' LE CRITERE DE RESTITUTION EST= FALSE
J = 0
For I = 1 To UBound(CombArray)
'If Not CombArray(I, 2) Then
If CombArray(I, 2) = False Then
Sortie.Offset(J, 0).Value = CombArray(I, 1)
J = J + 1
End If
Next I
Cells(5, 8) = J
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Erase CombArray
Set Plage1 = Nothing: Set Plage2 = Nothing: Set Sortie = Nothing
Tempo = 0
.Activate
End With
End Sub
Bonne journée