creer liste déroulante via macro

ActiveSheet.Range("B1").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=$A$1:$A$5"

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call DelListe
With Target
  If .Column <> COLONNE_LISTBOX Then Exit Sub
  If .Rows.Count > 1 Or .Columns.Count > 1 Then Exit Sub
  If .Row = 1 Then Exit Sub
  If ActiveSheet.Columns(COLONNE_LISTBOX).ColumnWidth < 30 Then
    MsgBox "Veuillez élargir la colonne."
    Exit Sub
  End If
End With
Call AddListe(Target)
End Sub

'### Constantes à adapter à votre usage ###
Const CATALOGUE As String = "catalogue"
Public Const COLONNE_LISTBOX As Long = 3
'##########################################

Sub AddListe(R As Range)
Dim Sh As Worksheet
Dim Sh2 As Worksheet
Dim R2 As Range
Dim S As Shape
Set Sh = R.Parent
Set Sh2 = ThisWorkbook.Sheets(CATALOGUE)
  '/// Les données de la feuille catalogue doivent commencer ///
  '/// en C2. Pour l'instant elles se terminent en colonne E ///
  '/// Pour une extension de colonne, modifiez le 5 final    ///
Set R2 = Sh2.Range(Sh2.Cells(2, 3), Sh2.Cells(Sh2.[c65536].End(xlUp).Row, 5))
  '////////////////////////////////////////////////////////////
Set S = Sh.Shapes.AddFormControl(xlDropDown, _
  R.Width / 5 * 4 + R.Left, R.Top + 1.5, (R.Width / 4), R.Height - 1.5)
S.ControlFormat.ListFillRange = Sh2.Name & "!" & R2.Address
S.OnAction = "DropDownSurClic"
S.Select
Selection.DropDownLines = 12
R.Select
End Sub

Sub DropDownSurClic()
Dim S As Shape
Dim DD As DropDown
Dim R As Range
Dim A$
Dim B$
Dim var
Dim Ref$
Dim T()
Dim i&
For Each S In ActiveSheet.Shapes
  If S.FormControlType = xlDropDown Then
    Set DD = S.OLEFormat.Object
    Exit For
  End If
Next S
Ref$ = DD.ListFillRange
A$ = Mid(Ref$, 1, InStr(1, Ref$, "!") - 1)
B$ = Mid(Ref$, Len(A$) + 2)
Set R = Sheets(A$).Range(B$)
var = R
ReDim T(1 To 1, 1 To UBound(var, 2))
For i& = 1 To UBound(var, 2)
  T(1, i&) = var(DD.ListIndex, i&)
Next i&
i& = DD.TopLeftCell.Row
Set R = ActiveSheet.Range(Cells(i&, 2), Cells(i&, UBound(var, 2) + 1))
R = T
End Sub

Sub DelListe(Optional dummy As Byte)
Dim S As Shape
For Each S In ActiveSheet.Shapes
  If S.FormControlType = xlDropDown Then
    S.Cut
    Exit For
  End If
Next S
End Sub