XL 2016 Limiter la Saisie dans un Combobox

Option Explicit
Option Compare Text
Public TexteVide As String
Function SujetCBx(ByVal Src, Optional ByVal Croissant As Boolean = True, Optional ByVal Format As String = "", _
   Optional ByVal Base As Long = 1, Optional ByVal Colonne As Long = 1)
   Dim TDon(), K As Long, LesClés(), LesListes(), TIdx() As Long, X As Long, L As Long, Lignes() As Long, _
      TypA As Long, TypB As Long, ValA, ValB, N As Long, Rupture As Boolean
   If TexteVide = "" Then TexteVide = "(vide)"
   Select Case True
      Case TypeOf Src Is Range: If Src.Rows.Count > 1 Then TDon = Src.Columns(Colonne).Value _
         Else ReDim TDon(1 To 1, 1 To 1): TDon(1, 1) = Src.Columns(Colonne).Value
      Case TypeOf Src Is ListColumn: L = Src.Parent.ListRows.Count: If L > 1 Then TDon = Src.DataBodyRange.Value _
         Else ReDim TDon(1 To 1, 1 To 1): If L = 1 Then TDon(1, 1) = Src(1).Range.Value
      Case VarType(Src) = vbArray + vbVariant
         If UBound(Src, 2) <> 1 Or Colonne <> 1 Then
            If Colonne > UBound(Src, 2) Then MsgBox "Colonne " & Colonne & " > " & UBound(Src, 2), vbCritical, "SujetCBx": End
            ReDim TDon(1 To UBound(Src, 1), 1 To 1): For L = 1 To UBound(TDon, 1): TDon(L, 1) = Src(L, Colonne): Next L
         Else: TDon = Src: End If
      Case Else: MsgBox "Type de source """ & TypeName(Src) & """ non supportée.", vbCritical, "SujetCBx", vbCritical: End
      End Select
   ReDim LesClés(0 To &H3FF&), LesListes(0 To &H3FF&): K = -1
   IndexerFus1Col TIdx, TDon, Croissant
   X = 1: L = TIdx(1): GoSub TestRuptureEtMiseEnForme
   ReDim Lignes(Base To &H3FF&)
   Do While X <= UBound(TIdx): TypA = TypB: ValA = ValB: K = K + 1
      If K > UBound(LesClés) Then ReDim Preserve LesClés(0 To K Or &H1FF&), LesListes(0 To K Or &H1FF&)
      LesClés(K) = ValA: N = Base
      Do: Lignes(N) = L: X = X + 1: If X > UBound(TIdx) Then Exit Do
         L = TIdx(X): GoSub TestRuptureEtMiseEnForme: If Rupture Then Exit Do
         N = N + 1: If N >= UBound(Lignes) Then ReDim Preserve Lignes(Base To N Or &H1FF&) As Long
         Loop
      ReDim Preserve Lignes(Base To N) As Long
      LesListes(K) = Lignes: Loop
   ReDim Preserve LesClés(0 To K), LesListes(0 To K)
   SujetCBx = Array(LesClés, LesListes)
   Exit Function
TestRuptureEtMiseEnForme: ValB = TDon(L, 1): TypB = VarType(ValB)
   Select Case TypB
      Case vbBoolean: ValB = IIf(ValB, "VRAI", "FAUX")
      Case vbError: ValB = Choose((CInt(ValB) - 1993) \ 7, "#NUL!", "#DIV/0!", _
         "#VALEUR!", "#REF!", "#NOM?", "#NOMBRE!", "#N/A")
      Case vbEmpty: TypB = &H8000&: ValB = TexteVide
      Case Else: ValB = VBA.Format$(ValB, Format): End Select
   Rupture = TypB <> TypA: If Rupture Then Return
   Rupture = ValB <> ValA: Return
   End Function
Function SujCBxFiltré(ByVal SujOrg, Quoi() As Long)
   Dim TConsult() As Boolean, LesClés(), LesListes(), KS As Long, KE As Long, Lignes() As Long
   CréerTConsult TConsult, Quoi
   LesClés = SujOrg(0): LesListes = SujOrg(1): KS = -1
   For KE = 0 To UBound(LesClés)
      Lignes = LesListes(KE)
      If IlEnResteFiltrés(Lignes, TConsult) Then
         KS = KS + 1: LesClés(KS) = LesClés(KE): LesListes(KS) = Lignes: End If: Next KE
   If KS < 0 Then ReDim LesClés(-1 To -1), LesListes(-1 To -1) Else _
         ReDim Preserve LesClés(0 To KS), LesListes(0 To KS)
   SujCBxFiltré = Array(LesClés, LesListes)
   End Function
Function IlEnResteFiltrés(TLong() As Long, TConsult() As Boolean) As Boolean
   Dim R As Long, N As Long, L As Long
   R = LBound(TLong) - 1: On Error GoTo 2
   For N = LBound(TLong) To UBound(TLong)
      L = TLong(N): If TConsult(L) Then R = R + 1: TLong(R) = L
1     Next N: On Error GoTo 0
   If R >= LBound(TLong) Then ReDim Preserve TLong(LBound(TLong) _
      To R): IlEnResteFiltrés = True Else Erase TLong
   Exit Function
2  If Err.Number = 9 Then Resume 1 Else On Error GoTo 0: Resume 'Indice hors limites
   End Function
Function SujAvecSuivants(ByVal SujOrg)
   Dim LesClés(), LesListes(), NouvListes(), Ke1 As Long, Ke2 As Long, _
       TLe() As Long, TLs() As Long, NDéb As Long, N As Long
   LesClés = SujOrg(0): LesListes = SujOrg(1): ReDim NouvListes(0 To UBound(LesListes))
   For Ke1 = 0 To UBound(LesClés): TLs = LesListes(Ke1)
      For Ke2 = Ke1 + 1 To UBound(LesClés): TLe = LesListes(Ke2)
         NDéb = UBound(TLs): ReDim Preserve TLs(1 To UBound(TLe) + NDéb)
         For N = 1 To UBound(TLe): TLs(NDéb + N) = TLe(N): Next N, Ke2
      NouvListes(Ke1) = TLs: Next Ke1
   SujAvecSuivants = Array(LesClés, NouvListes)
   End Function
Function SujAvecPrécédents(ByVal SujOrg)
   Dim LesClés(), LesListes(), NouvListes(), Ke1 As Long, Ke2 As Long, _
       TLe() As Long, TLs() As Long, NDéb As Long, N As Long
   LesClés = SujOrg(0): LesListes = SujOrg(1): ReDim NouvListes(0 To UBound(LesListes))
   For Ke1 = 0 To UBound(LesClés): TLs = LesListes(0)
      For Ke2 = 1 To Ke1: TLe = LesListes(Ke2)
         NDéb = UBound(TLs): ReDim Preserve TLs(1 To UBound(TLe) + NDéb)
         For N = 1 To UBound(TLe): TLs(NDéb + N) = TLe(N): Next N, Ke2
      NouvListes(Ke1) = TLs: Next Ke1
   SujAvecPrécédents = Array(LesClés, NouvListes)
   End Function
Function SujCBxLike(ByVal SujOrg, ByVal Masque As String)
   Dim LesClés(), LesListes(), KS As Long, KE As Long
   Masque = UCase(Masque)
   LesClés = SujOrg(0): LesListes = SujOrg(1): KS = -1
   For KE = 0 To UBound(LesClés)
      If UCase(LesClés(KE)) Like Masque Then
         KS = KS + 1: If KS < KE Then LesClés(KS) = LesClés(KE): LesListes(KS) = LesListes(KE)
         End If: Next KE
   If KS < 0 Then Exit Function
   ReDim Preserve LesClés(0 To KS), LesListes(0 To KS)
   SujCBxLike = Array(LesClés, LesListes)
   End Function
Function SujetMotsClés(ByVal Src, Optional ByVal Séparat As String = " ")
   Dim CarEspac As String, N As Long, TDon(), LE As Long, Mot As String, TSpl() As String, LS As Long, _
      Mots() As Variant, LgnOrg() As Long, Sujet, LesListes() As Variant, TLgn() As Long, YEnAPas As Boolean
   CarEspac = "!""#$%&'()*+,-./:;<=>?@[\]^_`{|}~¡¦§¨«¬®¯»¿"
   For N = 1 To Len(Séparat): CarEspac = Replace$(CarEspac, Mid$(Séparat, N, 1), ""): Next N
   If TypeName(Src) = "Range" Then TDon = Src.Value Else TDon = Src
   For LE = 1 To UBound(TDon)
      Mot = TDon(LE, 1): For N = 1 To Len(Mot)
         If InStr(CarEspac, Mid$(Mot, N, 1)) > 0 Then Mid$(Mot, N, 1) = " "
         Next N
      TSpl = Split(Mot, Séparat)
      YEnAPas = True
      For N = 0 To UBound(TSpl): Mot = Trim$(TSpl(N))
         If Mot <> "" Then
            Mid$(Mot, 1, 1) = UCase$(Mid$(Mot, 1, 1)): LS = LS + 1: ReDim Preserve Mots(1 To LS), LgnOrg(1 To LS)
            Mots(LS) = Mot: LgnOrg(LS) = LE: YEnAPas = False: End If
         Next N
      If YEnAPas Then
         LS = LS + 1: ReDim Preserve Mots(1 To LS), LgnOrg(1 To LS)
         Mots(LS) = Empty: LgnOrg(LS) = LE: End If
      Next LE
   Sujet = SujetCBx(WorksheetFunction.Transpose(Mots))
   LesListes = Sujet(1)
   For N = LBound(LesListes) To UBound(LesListes)
      TLgn = LesListes(N)
      For LS = LBound(TLgn) To UBound(TLgn): TLgn(LS) = LgnOrg(TLgn(LS)): Next LS
      LesListes(N) = TLgn
      Next N
   SujetMotsClés = Array(Sujet(0), LesListes)
   End Function
Function SujMultiCol(ByVal Src, Optional ByVal CDéb As Integer = 1, Optional ByVal CFin _
   As Integer = &H7FFF, Optional ByVal Pas As Integer = 1, Optional ByVal Format As String)
   Dim TDon(), LDon As Long, CDon As Long, LAuxMax As Long, LAux As Long, TAuxClé(), TAuxLgn() As Long, _
      Sujet, LesListes(), N As Long, TLgn() As Long, L As Long
   If TypeOf Src Is Excel.Range Then TDon = Src.Value Else TDon = Src
   If CFin > UBound(TDon, 2) Then CFin = UBound(TDon, 2)
   For LDon = 1 To UBound(TDon, 1): For CDon = CDéb To CFin Step Pas
      If Not IsEmpty(TDon(LDon, CDon)) Then LAuxMax = LAuxMax + 1
      Next CDon, LDon
   ReDim TAuxClé(1 To LAuxMax, 1 To 1), TAuxLgn(1 To LAuxMax)
   For LDon = 1 To UBound(TDon, 1): For CDon = CDéb To CFin Step Pas
      If Not IsEmpty(TDon(LDon, CDon)) Then
         LAux = LAux + 1: TAuxClé(LAux, 1) = TDon(LDon, CDon): TAuxLgn(LAux) = LDon
         End If: Next CDon, LDon
   Sujet = SujetCBx(TAuxClé, Format:=Format)
   LesListes = Sujet(1)
   For N = 0 To UBound(LesListes): TLgn = LesListes(N)
      For L = 1 To UBound(TLgn): TLgn(L) = TAuxLgn(TLgn(L)): Next L
      LesListes(N) = TLgn: Next N
   SujMultiCol = Array(Sujet(0), LesListes)
   End Function
Function SujCBxClésSuppl(ByVal SujOrg, ByVal ClésSuppl As Variant)
   Dim Cln As Collection, Élé, LesClés(), LesListes(), K As Long
   If TypeOf ClésSuppl Is Range Then ClésSuppl = ClésSuppl.Value
   For Each Élé In ClésSuppl: Cln.Add Item:=CStr(Élé), Key:=CStr(Élé): Next Élé
   LesClés = SujOrg(0): LesListes = SujOrg(1)
   On Error Resume Next
   For K = 0 To UBound(LesClés): Cln.Remove LesClés(K): Next K
   On Error GoTo 0
   K = UBound(LesClés): ReDim Preserve LesClés(0 To K + Cln.Count), LesListes(0 To K + Cln.Count)
   For Each Élé In Cln: K = K + 1: LesClés(K) = Élé: Next Élé
   SujCBxClésSuppl = Array(LesClés, LesListes)
   End Function
Function TLgnLBx(ByVal LBx As MSForms.ListBox, Sujet) As Long()
   ÉtablirTLgnLBx TLgnLBx, LBx, Sujet
   End Function
Sub ÉtablirTLgnLBx(TLgn() As Long, ByVal LBx As MSForms.ListBox, ByVal Sujet)
   Dim LLBx As Long, TConsult() As Boolean, TLSuj() As Long
   For LLBx = 0 To LBx.ListCount - 1
      If LBx.Selected(LLBx) Then TLSuj = Sujet(1)(LLBx): CombinTConsultOU TConsult, TLSuj
      Next LLBx
   CréerListeVrais TLgn, TConsult
   End Sub
Function DicoSujet(ByVal Sujet) As Dictionary
   Set DicoSujet = New Dictionary
   Dim LesClés(), LesListes(), N As Long
   LesClés = Sujet(0): LesListes = Sujet(1)
   For N = 0 To UBound(LesClés)
      DicoSujet.Add Key:=LesClés(N), Item:=LesListes(N)
      Next N
   End Function
Function TConsult(TLong() As Long) As Boolean()
   CréerTConsult TConsult, TLong
   End Function
Sub CréerTConsult(TConsult() As Boolean, TLong() As Long)
   Erase TConsult: CombinTConsultOU TConsult, TLong
   End Sub
Sub CombinTConsultOU(TConsult() As Boolean, TLong() As Long)
   Dim N As Long, L As Long, LMin As Long, LMax As Long, LMnO As Long, LMxO As Long
   LMin = &H7FFFFFFF: LMax = -LMin
   For N = LBound(TLong) To UBound(TLong): L = TLong(N)
      If LMax < L Then LMax = L
      If LMin > L Then LMin = L
      Next N
   On Error Resume Next: LMnO = LBound(TConsult): LMxO = UBound(TConsult)
   If Err Then ReDim TConsult(LMin To LMax): LMnO = LMin: LMxO = LMax
   On Error GoTo 0
   If LMin < LMnO Then
      Dim T() As Boolean: T = TConsult
      ReDim TConsult(LMin To LMxO): For L = LMnO To LMxO: TConsult(L) = T(L): Next L
      LMnO = LMin: End If
   If LMax > LMxO Then ReDim Preserve TConsult(LMnO To LMax)
   For N = LBound(TLong) To UBound(TLong): L = TLong(N): TConsult(L) = True: Next N
   End Sub
Function ListeVrais(TConsult() As Boolean, Optional ByVal Base As Long = 1) As Long()
   CréerListeVrais ListeVrais, TConsult, Base
   End Function
Sub CréerListeVrais(TLong() As Long, TConsult() As Boolean, Optional ByVal Base As Long = 1)
   Dim L As Long, N As Long
   ReDim TLong(Base To UBound(TConsult) - LBound(TConsult) + Base): N = Base - 1
   For L = LBound(TConsult) To UBound(TConsult)
      If TConsult(L) Then N = N + 1: TLong(N) = L
      Next L: If N >= Base Then ReDim Preserve TLong(Base To N) Else Erase TLong
   End Sub
Sub IndexerFus1Col(TIdx() As Long, TDon(), _
   Optional ByVal Croissant As Boolean = True, Optional ByVal LMax As Long)
   Dim NR As Long, ÀFusionner As New Collection, _
       L1 As Long, TFus1() As Long, N1 As Long, Arg1, _
       L2 As Long, TFus2() As Long, N2 As Long, Arg2
   If LMax <= 0 Then LMax = UBound(TDon, 1)
   ReDim TIdx(1 To &HFFF&)
   NR = 1: TIdx(1) = 1: L1 = 1: Arg1 = TDon(1, 1)
   If VarType(Arg1) = vbString Then If Arg1 = "" Then Arg1 = Empty: TDon(1, 1) = Empty
   For L2 = 2 To LMax: Arg2 = TDon(L2, 1)
      If VarType(Arg2) = vbString Then If Arg2 = "" Then Arg2 = Empty: TDon(L2, 1) = Empty
      If DansLOrdre(Arg1, Arg2, Croissant, L1 < L2) Then
         NR = NR + 1: If NR > UBound(TIdx) Then ReDim Preserve TIdx(1 To NR Or &HFFF&)
         TIdx(NR) = L2: L1 = L2: Arg1 = Arg2
      ElseIf NR < 20 Then
         For N1 = 1 To NR - 1: L1 = TIdx(N1): If DansLOrdre(Arg2, TDon(L1, 1), Croissant, L1 > L2) Then Exit For
            Next N1
         NR = NR + 1: If NR > UBound(TIdx) Then ReDim Preserve TIdx(1 To NR Or &HFFF&)
         For N2 = NR To N1 + 1 Step -1: TIdx(N2) = TIdx(N2 - 1): Next N2
         TIdx(N1) = L2: L1 = TIdx(NR): Arg1 = TDon(L1, 1)
      Else: ReDim Preserve TIdx(1 To NR): ÀFusionner.Add TIdx: NR = 1
         TIdx(1) = L2: L1 = L2: Arg1 = Arg2: End If
      Next L2
   ReDim Preserve TIdx(1 To NR)
   Do While ÀFusionner.Count > 0
      ÀFusionner.Add TIdx
      TFus1 = ÀFusionner(1): N1 = 1: ÀFusionner.Remove 1
      TFus2 = ÀFusionner(1): N2 = 1: ÀFusionner.Remove 1
      ReDim TIdx(1 To UBound(TFus1) + UBound(TFus2))
      L1 = TFus1(1): Arg1 = TDon(L1, 1)
      L2 = TFus2(1): Arg2 = TDon(L2, 1)
      NR = 0: Do: NR = NR + 1
         If DansLOrdre(Arg1, Arg2, Croissant, L1 < L2) Then
               TIdx(NR) = L1: N1 = N1 + 1: If N1 <= UBound(TFus1) Then L1 = TFus1(N1): Arg1 = TDon(L1, 1) Else GoTo Fin2
         Else: TIdx(NR) = L2: N2 = N2 + 1: If N2 <= UBound(TFus2) Then L2 = TFus2(N2): Arg2 = TDon(L2, 1) Else Exit Do
            End If
         Loop
      Do: NR = NR + 1: TIdx(NR) = TFus1(N1): N1 = N1 + 1: Loop Until N1 > UBound(TFus1): GoTo FusS
Fin2: Do: NR = NR + 1: TIdx(NR) = TFus2(N2): N2 = N2 + 1: Loop Until N2 > UBound(TFus2)
FusS: Loop
   End Sub
Private Function DansLOrdre(ByVal Val1, ByVal Val2, ByVal Croissant As Boolean, ByVal ParDéf As Boolean) As Boolean
   Dim Typ1 As VbVarType, Typ2 As VbVarType, Sens As Integer, Comp As Integer
   Sens = 2 * -Croissant - 1
   Typ1 = VarType(Val1): Typ2 = VarType(Val2)
   Select Case Typ2
      Case Is <> Typ1: Comp = Sgn(Typ2 - Typ1)
      Case vbString: Comp = StrComp(Val2, Val1) * Sens
      Case vbError: Comp = Sgn(CLng(Val2) - CLng(Val1)) * Sens
      Case vbEmpty: Comp = 0
      Case Else: Comp = Sgn(Val2 - Val1) * Sens: End Select
   If Comp = 0 Then DansLOrdre = ParDéf Else DansLOrdre = Comp > 0
   End Function