'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
'°°° Faire référence à la librairie °°°
'°°° Library MSForms °°°
'°°° Microsoft Forms 2.0 Object Library °°°
'°°° C:\WINDOWS\system32\FM20.DLL °°°
'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
'### Constantes à adapter ###
Public Const BDD_FOURNISSEURS As String = "fiche fournisseur"
Public Const OLE_NAME As String = "ole_perso_pmo"
Public Const CELLULE_LIEE As String = "d3"
Public Const CELL_DEST As String = "g3"
Const VALIDITE_CELLULE As String = "c1"
Const VALIDITE_VALUE As String = "Réclamation"
Const CALAGE As String = "Identification du fournisseur"
'############################
Sub ChoixFournisseur()
Dim S As Worksheet
Dim Plage As Range
Dim R As Range
Dim firstAddress$
Dim T()
Dim var
Dim i&
Dim OleX As OLEObject
Dim LB As MSForms.ListBox
With ActiveSheet
If .Range(VALIDITE_CELLULE) <> VALIDITE_VALUE Then Exit Sub
If .Range(CELLULE_LIEE) <> "" Then Exit Sub
End With
Set S = Sheets(BDD_FOURNISSEURS)
Set Plage = S.UsedRange
With Plage
Set R = .Find(CALAGE, LookIn:=xlValues)
If Not R Is Nothing Then
firstAddress$ = R.Address
Do
i& = i& + 1
ReDim Preserve T(1 To 2, 1 To i&)
T(1, i&) = R.Offset(2, 0)
T(2, i&) = R.Offset(-1, 0).Address
Set R = .FindNext(R)
Loop While Not R Is Nothing And R.Address <> firstAddress$
End If
End With
var = Application.WorksheetFunction.Transpose(T)
Set R = ActiveSheet.Range(CELLULE_LIEE).Offset(0, -1)
Set OleX = ActiveSheet.OLEObjects.Add( _
ClassType:="Forms.ListBox.1", _
Left:=R.Left + R.Width, _
Top:=R.Top, _
Width:=150, _
Height:=60)
OleX.Verb xlPrimary
OleX.LinkedCell = ActiveSheet.Range(CELLULE_LIEE).Address
OleX.Name = OLE_NAME
Set LB = OleX.Object
LB.ColumnCount = 2
LB.BoundColumn = 1
LB.ColumnWidths = "50;0"
LB.List() = var
Set LB = Nothing
Set OleX = Nothing
Set R = Nothing
Set Plage = Nothing
Set S = Nothing
End Sub
