XL 2013 Recherche avec plusieurs criteres

Dim TblBD(), nomTableau, NbCol, ColVisu(), Dates(), Choix()
Private Sub UserForm_Initialize()
  nomTableau = "Tableau1"
  TblBD = Range(nomTableau).Value           ' pour rapidité
  For i = 1 To UBound(TblBD): TblBD(i, 4) = CDate(TblBD(i, 4)): Next i
  Me.ListBox1.ColumnCount = Range(nomTableau).Columns.Count + 1
  NbCol = Range(nomTableau).Columns.Count
  ColVisu = Array(1, 2, 3, 4, 5, 6, 7)    ' colonnes à visualiser (adapter)
  EnteteListBox
  '---- compte
  Set d = CreateObject("scripting.dictionary")
  d("*") = ""
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, 1)) = ""
  Next i
  Choix = d.keys
  Me.ComboBox1.List = Choix
  '---Dates
  Set d = CreateObject("scripting.dictionary")
  colDate = 4
  For i = LBound(TblBD) To UBound(TblBD)
    d(TblBD(i, colDate)) = ""
  Next i
  Dates = d.keys
  Tri Dates, LBound(Dates), UBound(Dates)
  Me.ComboBox2.List = Dates: Me.ComboBox2 = Dates(0)
  Me.ComboBox3.List = Dates: Me.ComboBox3 = Dates(UBound(Dates))
  Filtre
  Me.ComboTri.List = Application.Transpose(Range(nomTableau).Offset(-1).Resize(1))  ' Ordre tri
End Sub

Private Sub ComboBox2_click()
   Filtre
End Sub

Private Sub ComboBox3_click()
  Filtre
End Sub

Private Sub ComboBox1_change()
   Set d1 = CreateObject("Scripting.Dictionary")
   tmp = Me.ComboBox1 & "*"      ' "*" & Me.ComboFiltre & "*"  pour recherche dans intitulés
   For Each c In Choix
      If c Like tmp Then d1(c) = ""
   Next c
   Me.ComboBox1.List = d1.keys
   Me.ComboBox1.DropDown
End Sub

Private Sub ComboBox1_click()  ' alimentation ListBox
   Filtre
End Sub

Sub Filtre()
    Dim Tbl()
    clé = Me.ComboBox1: If clé = "" Then clé = "*"
    début = CDate(Me.ComboBox2)
    fin = CDate(Me.ComboBox3)
    colDate = 4
    n = 0
    totCredit = 0: totDebit = 0
    For i = LBound(TblBD) To UBound(TblBD)
      If TblBD(i, colDate) >= début And TblBD(i, colDate) <= fin And TblBD(i, 1) Like clé Then
        n = n + 1: ReDim Preserve Tbl(1 To NbCol + 1, 1 To n)
        c = 0
        For Each k In ColVisu
          c = c + 1: Tbl(c, n) = TblBD(i, k)
          If c = 6 Or c = 7 Then Tbl(c, n) = Tbl(c, n) '  Format(Tbl(c, n), "## 000 000")
        Next k
        totCredit = totCredit + TblBD(i, 7): totDebit = totDebit + TblBD(i, 6)
        c = c + 1: Tbl(c, n) = totCredit - totDebit   'Format(totCredit - totDebit, "## 000 000")   ' solde cumulé
       End If
     Next i
     '-- totaux
     If n > 0 Then
       Me.ListBox1.Column = Tbl
       Me.TotCred = Format(totCredit, "## 000 000"): Me.TotDeb = Format(totDebit, "## 000 000")
     Else
       Me.ListBox1.Clear
       Me.TotCred = 0: Me.TotDeb = 0
     End If
End Sub

Private Sub b_tout_Click()
  Me.ComboBox2.List = Dates: Me.ComboBox2 = Dates(0)
  Me.ComboBox3.List = Dates: Me.ComboBox3 = Dates(UBound(Dates))
  Me.ComboBox1 = "*"
  Filtre
End Sub

Private Sub ComboTri_click()
  Dim Tbl()
  colTri = Me.ComboTri.ListIndex
  Tbl = Me.ListBox1.List
  TriMultiCol Tbl, LBound(Tbl), UBound(Tbl), colTri
  Me.ListBox1.List = Tbl
End Sub

Private Sub B_recup_Click()
  Set f2 = Sheets("résultat")
  f2.[A5:H10000].ClearContents
  f2.[E1] = Me.ComboBox2:  f2.[E2] = Me.ComboBox3
  f2.[A2] = Me.ComboBox1
  f2.[f2] = Replace(Me.TotDeb, " ", "")
  f2.[G2] = Replace(Me.TotCred, " ", "")
  a = Me.ListBox1.List
  f2.[A5].Resize(UBound(a) + 1, UBound(a, 2) + 1) = a
  Unload Me
  Set Rng = f2.Range("A1").CurrentRegion
  f2.PageSetup.PrintArea = Rng.Address
  f2.PrintPreview
End Sub