'//////////////////////////////////////////
'/// Nécessite la librairie suivante ///
'/// (faire menu Outils/Références...) ///
'/// Library MSForms ///
'/// C:\WINDOWS\system32\FM20.DLL ///
'/// Microsoft Forms 2.0 Object Library ///
'//////////////////////////////////////////
'### Constantes à adapter ###
Public Const SHEET_BDD As String = "BDD"
Public Const NB_CAR As Long = 4
Public Const SEPARATEUR As String = " "
'############################
Public myColl As New Collection
Sub CreeComboBox()
Dim OL As OLEObject
Dim CB As ComboBox
Dim R As Range
Dim i&
Dim T()
'---
Set R = ActiveCell.Offset(0, 1)
Set OL = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, _
DisplayAsIcon:=False, Left:=R.Left, Top:=R.Top, Width:=R.Width + R.Offset(0, 1).Width, Height:=R.Height + 5)
Set CB = OL.Object
'---
If myColl.Count > 0 Then
ReDim T(1 To myColl.Count)
For i& = 1 To myColl.Count
T(i&) = myColl.Item(i&)
Next i&
End If
'---
CB.List = T
CB.LinkedCell = R.Address
'---
Set OL = Nothing
Set CB = Nothing
End Sub
Sub CreeCollection()
Dim A$
Dim B$
Dim C$
Dim var
Dim k&
Dim i&
'---
A$ = CStr(ActiveCell)
If A$ = "" Then Exit Sub
var = Sheets("BDD").[a1].CurrentRegion
'---
For k& = 1 To Len(A$) - NB_CAR
B$ = Mid(A$, k&, NB_CAR + k& - 1)
For i& = 2 To UBound(var, 1)
If InStr(1, UCase(var(i&, 1)), UCase(B$)) > 0 Then
On Error Resume Next
C$ = var(i&, 1) & SEPARATEUR & var(i&, 2)
myColl.Add C$, C$
On Error GoTo 0
End If
Next i&
Next k&
End Sub