Extraction de base de données avec critères et cellules Multi informations

Private Sub CommandButton1_Click()
Dim TE(), LE&, TS(), LS&, C&, N
TE = CL.PlgTablo.Resize(, 6).Value
ReDim TS(1 To UBound(TLgn), 1 To 8)
For N = 1 To UBound(TLgn)
   If ListBox1.Selected(N - 1) Then
      LS = LS + 1: LE = TLgn(N)
      For C = 1 To 4: TS(LS, C) = TE(LE, C): Next C
      For C = 7 To 8: TS(LS, C) = TE(LE, C - 2): Next C
      End If: Next N
If LS = 0 Then Beep: Exit Sub
ActiveSheet.[B1010].End(xlUp).Offset(1).Resize(LS, 8).Value = TS
FiltrerDéjàInscrits
End Sub

Private Sub UserForm_Activate()
ComboBox_Loisir.Text = ActiveSheet.[A1].Value
FiltrerDéjàInscrits
End Sub
'

Private Sub FiltrerDéjàInscrits()
Dim TDéjà(1 To 999) As Boolean, TE(), LE&, TS(), LS&, C&
ComboBox_Loisir.Text = ActiveSheet.[A1].Value
TE = PlgUti(ActiveSheet.[B4])
For LE = 2 To UBound(TE): TDéjà(TE(LE, 1)) = True: Next LE
TE = CL.PlgTablo.Columns(1).Value
ReDim TLgn(1 To 999)
For LE = 1 To UBound(TE)
   If Not TDéjà(TE(LE, 1)) Then LS = LS + 1: TLgn(LS) = LE
   Next LE
ReDim Preserve TLgn(1 To LS)
CL.FiltrerLignes TLgn
End Sub

Dim f, TblBd
Private Sub UserForm_Initialize()
  Set f = Sheets("base de données")
  Set d = CreateObject("Scripting.Dictionary")
  TblBd = f.Range("a2:f" & f.[A65000].End(xlUp).Row)
  d("*") = ""
  For i = LBound(TblBd) To UBound(TblBd)
    a = Split(TblBd(i, 6), ";")
    For Each c In a: d(c) = "": Next c
  Next i
  Me.ComboBox1.List = d.keys
  Me.ComboBox2.List = Array("*", "F", "M")
  Me.ComboBox1 = ActiveSheet.[A1]
  ComboBox1_click
End Sub

Private Sub ComboBox1_click()
 ListBox1.Clear
 j = 0
 For i = LBound(TblBd) To UBound(TblBd)
   If (InStr(TblBd(i, 6), ComboBox1) > 0 And TblBd(i, 5) Like ComboBox2) _
     Or (Me.ComboBox1 = "*" And TblBd(i, 5) Like ComboBox2) Then
     Me.ListBox1.AddItem
     For k = 1 To 6
         ListBox1.List(j, k - 1) = TblBd(i, k)
     Next k
     j = j + 1
   End If
  Next i
End Sub

Private Sub ComboBox2_Click()
   ComboBox1_click
End Sub

Private Sub b_ajout_Click()
 For i = 0 To Me.ListBox1.ListCount - 1
     If Me.ListBox1.Selected(i) = True Then
       ref = Me.ListBox1.List(i, 0)
       Set result = [b2:b1000].Find(what:=ref, lookat:=xlWhole)
       If result Is Nothing Then
         ligne = [b65000].End(xlUp).Row + 1
         For k = 0 To 5
           ActiveSheet.Cells(ligne, k + 2) = Me.ListBox1.List(i, k)
         Next k
       End If
     End If
  Next i
End Sub

If LS = 0 Then
   Me.Hide
   MsgBox "Il n'y a plus personne à ajouter.", vbInformation, Me.Caption
   Unload Me: Exit Sub
   End If