re 🙂)
pour le fun (inspirée d'un code de Fred SIGONNEAU): et qui te servira à d'autres moments:
sélection d'une série de données en 1 colonne, (celle à sa droite doit être libre) , clic droit et les versions uniques apparaissent.
Option Explicit
Sub MenuCell() ' 1
Dim Ctrl
For Each Ctrl In Application.CommandBars('Cell').Controls
Ctrl.Enabled = True
Next
With Application.CommandBars('Cell').Controls.Add(msoControlButton)
.Caption = 'Unique à droite'
.BeginGroup = True
.FaceId = 252
.OnAction = 'ValUniquesACote'
End With
End Sub
' 2
Sub ValUniquesACote() ' PlageSrc As Range, CellDest As Range)
'Extrait les valeurs uniques d'une colonne et les renvoie
'dans une autre, à partir de CellDest tiré d'un code de F. Signonneau (pense-je)
Dim Arr1, Elt, Arr2(), Coll As New Collection, i As Integer
'If PlageSrc.Columns.Count > 1 Then Exit Sub ' Mais possible sur 2 colonnes
'Arr1 = PlageSrc.Value
Arr1 = Selection.Value
Dim Colo
Dim line
Dim err
Colo = Selection.Column
line = Selection.Row
For Each Elt In Arr1
On Error Resume Next
Coll.Add Elt, CStr(Elt)
If err.Number = 0 Then
ReDim Preserve Arr2(1 To Coll.Count)
Arr2(Coll.Count) = Elt
End If
On Error GoTo 0
Next
For i = 1 To Coll.Count
If IsEmpty(Cells(line, Colo + 1)) Then
Cells(line + i, Colo + 1).Value = Coll.Item(i)
Else
MsgBox ('cellule voisine non vide')
MsgBox Coll.Item(i)
End If
Next
Application.Transpose (Arr2)
End Sub
Sub Efface_ClicDroit() ' 3
On Error Resume Next
Application.CommandBars('Cell').Controls('Unique à droite').Delete
End Sub