Sub aaa()
'Nécessite l'ajout de la bibliothèque Microsoft Scripting Runtime au projet.
Dim i&, j&, k&, l&, n&, u&, s(), v(), w()
Dim Plg2 As Range, Plg1 As Range, Plg
Dim Table As New Scripting.Dictionary, Clef$, Clefs
'Paramètres:
Set Plg1 = Me.Range("B2:E8") 'Plage de données
Set Plg2 = Me.Range("H2") 'Cellule de destination
'____________________________________________________
Plg = Plg1.Value
Set Plg1 = Nothing
k = UBound(Plg)
'____________________________________________________
'Création de la table d'index selon la structure :
' Key = Clef (Une valeur de la première ou de la deuxième colonne de Plg1)
' Item = {type, {nombre1, ligne(1), ligne(2), ..., ligne(nombre1)}, {nombre2, ligne(1), ligne(2), ..., ligne(nombre2)}}
' type = 1 pour une clef ne figurant qu'en première colonne de Plg1
' type = 2 pour une clef ne figurant qu'en deuxième colonne de Plg1
' type = 3 pour une clef figurant dans les deux premières colonnes de Plg1
' nombre1 = nombre d'occurrences de la clef dans la première colonne de Plg1
' SI nombre1 > 0 : ligne(1), ligne(2), ..., ligne(nombre1) = numéros des lignes correspondantes dans Plg1
' nombre2 = nombre d'occurrences de la clef dans la deuxième colonne de Plg1
' SI nombre2 > 0 : ligne(1), ligne(2), ..., ligne(nombre1) = numéros des lignes correspondantes dans Plg1
'____________________________________________________
' 1. Clefs dans la première colonne de données :
Table.CompareMode = BinaryCompare
For i = 1 To k
Clef = Plg(i, 1)
If Clef <> "" Then
If IsNumeric(Clef) Then Clef = Right$(" " & Clef, 15)
If Table.Exists(Clef) Then
v = Table(Clef)
w = v(1)
ReDim Preserve w(1 + UBound(w))
w(0) = 1 + w(0)
w(UBound(w)) = i
v(1) = w
Table(Clef) = v
Else
Table.Add Clef, Array(1, Array(1, i), Array(0))
End If
l = l + 1
End If
Next
'____________________________________________________
' 2. Clefs dans la deuxième colonne de données :
For i = 1 To k
Clef = Plg(i, 2)
If Clef <> "" Then
If IsNumeric(Clef) Then Clef = Right$(" " & Clef, 15)
If Table.Exists(Clef) Then
v = Table(Clef)
v(0) = 3
w = v(2)
ReDim Preserve w(1 + UBound(w))
w(0) = 1 + w(0)
If v(1)(0) < w(0) Then l = l + 1
w(UBound(w)) = i
v(2) = w
Table(Clef) = v
Else
Table.Add Clef, Array(2, Array(0), Array(1, i))
l = l + 1
End If
End If
Next
'____________________________________________________
'Table des Clefs en ordre croissant :
Clefs = Table.Keys
n = UBound(Clefs)
For i = 0 To n - 1
Clef = Clefs(i)
u = 0
For j = i + 1 To n
If Clefs(j) < Clef Then u = j: Clef = Clefs(j)
Next
If u Then Clefs(u) = Clefs(i): Clefs(i) = Clef
Next
'____________________________________________________
'Sortie des résultats :
With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
With Plg2
.Resize(Rows.Count - Plg2.Row, 4).Clear
If l Then
ReDim s(1 To l, 1 To 4)
k = 0
For i = 0 To n
v = Table(Clefs(i))
Select Case v(0)
Case 1
w = v(1)
For j = 1 To w(0)
k = k + 1
s(k, 1) = Plg(w(j), 1)
Next
Case 2
w = v(2)
For j = 1 To w(0)
k = k + 1
For u = 2 To 4: s(k, u) = Plg(w(j), u): Next
Next
Case 3
w = Array(v(1), v(2))
u = (w(0)(0) + w(1)(0) + Abs(w(0)(0) - w(1)(0))) / 2
For j = 1 To u
k = k + 1
If j <= w(0)(0) Then s(k, 1) = Plg(w(0)(j), 1)
If j <= w(1)(0) Then For u = 2 To 4: s(k, u) = Plg(w(1)(j), u): Next
Next
End Select
Next
With .Resize(k, 4)
.Value = s
.Borders.LineStyle = xlContinuous
End With
End If
End With
With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
'____________________________________________________
'Facultatif : ménage de printemps...
Set Table = Nothing
Set Plg2 = Nothing
Erase s, v, w
'____________________________________________________
End Sub