Manipuler un tableau vba

Sub Rapprochement_Forum()
Dim Tableau, Tableau2, d As Object
Dim i As Integer

'Mise en tableau de la zone
Tableau = Feuil1.Range("b5:g" & Feuil1.[b65000].End(xlUp).Row)

'On crée un index du tableau pour les valeurs supérieures à zéro en quatrième colonne
With Feuil3
Set d = CreateObject("scripting.Dictionary")
'On boucle le tableau sur la colonne 3 (les tableaux commencent à 0)
For i = LBound(Tableau) To UBound(Tableau)
    'Si la valeur est supérieure à 0 on ajoute le numéro de ligne à l'index
    If Tableau(i, 3) > 0 Then d(1) = d(1) & i & ":"
Next i
    'On extrait les lignes du premier tableau dans un second ainsi que les colonnes souhaitées
    Tableau2 = Application.Index(Tableau, Application.Transpose(Split(d(1), ":")), Array(1, 2, 3))
    'On insère les valeurs dans A1 de la feuille3
    .[a1].Resize(UBound(Tableau2) - 1, 3).Value = Tableau2
End With
End Sub

Sub Rapp2()
Dim TE(), LE&, TR(), LR&, C&
With Application: .ScreenUpdating = False: .Calculation = xlManual: End With
Start = Timer

TE = Feuil1.Range("B5:G" & Feuil1.Range("G" & Rows.Count).End(xlUp).Row)
Rem. Vu le contexte, TE = Feuil1.AutoFilter.Range.Value et commencer
'    la boucle à LE = 2 marcherait aussi.
ReDim TR(1 To UBound(TE, 1), 1 To 3)
For LE = 1 To UBound(TE)
   If TE(LE, 6) = "Cl" Then
      LR = LR + 1
      For C = 1 To 3: TR(LR, C) = TE(LE, C): Next C
      End If: Next LE
Feuil3.[B6].Resize(UBound(TR, 1), 3).Value = TR

MsgBox "durée du traitement: " & Timer - Start & " secondes"
With Application: .ScreenUpdating = True: .Calculation = xlAutomatic: End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Range("b4:g44").AutoFilter Field:=6, Criteria1:="Cl", Operator:=xlAnd
Range("b5:d44").SpecialCells(xlCellTypeVisible).Copy Feuil3.Range("b65536").End(xlUp)(2)
End Sub

If Tableau(i, 3) > 0
'Par
If Tableau(i, 5) = "Cl"

Sub test()
Dim x
    If Application.CountIf(Sheets("Feuil1").Columns(7), "cl") = 0 Then Exit Sub
    With Sheets("feuil1")
        With .Range("b4").CurrentRegion
            x = Filter(.Parent.Evaluate("transpose(if((" & .Columns(1).Address & _
                "=""date"")+(" & .Columns(6).Address & "=""cl""),row(1:" & _
                .Rows.Count & "),char(2)))"), Chr(2), 0)
            x = Application.Index(.Value, Application.Transpose(x), [{1,2,3}])
        End With
    End With
    Sheets("Feuil2").Range("a1").End(xlUp).Resize(UBound(x, 1), 3).FormulaLocal = x
End Sub

Sub Rapp2()
Dim TE(), LE&, TR(), LR&, C&, X As ListRows
With Application: .ScreenUpdating = False: .Calculation = xlManual: End With
Start = Timer

TE = Feuil1.Range("B5:G" & Feuil1.Range("G" & Rows.Count).End(xlUp).Row)
Rem. Vu le contexte, TE = Feuil1.AutoFilter.Range.Value et commencer
'    la boucle à LE = 2 marcherait aussi.
ReDim TR(1 To UBound(TE, 1), 1 To 3)
For LE = 1 To UBound(TE)
   If TE(LE, 6) = "Cl" Then
      LR = LR + 1
      For C = 1 To 3: TR(LR, C) = TE(LE, C): Next C
      End If: Next LE
With Feuil3.[B6].ListObject.ListRows
   If .Count > LR Then .Item(LR + 1).Range.EntireRow.Resize(.Count - LR).Delete
   End With
Feuil3.[B6].Resize(LR, 3).Value = TR

MsgBox "durée du traitement: " & Timer - Start & " secondes"
With Application: .ScreenUpdating = True: .Calculation = xlAutomatic: End With
End Sub

Sub test()
Dim r As Range, ff As String, x As Range
    If Application.CountIf(Sheets("Feuil1").Columns(7), "cl") = 0 Then Exit Sub
    With Sheets("Feuil1").Range("B4").CurrentRegion
        With .Columns(6)
            Set r = .Find("cl", , , 1)
            If Not r Is Nothing Then
                ff = r.Address
                Do
                    If x Is Nothing Then
                        Set x = Union(.Cells(, -4), .Cells(, -3), .Cells(, -2), r(, -4), r(, -3), r(, -2))
                    Else
                        Set x = Union(x, r(, -4), r(, -3), r(, -2))
                    End If
                    Set r = .FindNext(r)
                Loop Until r.Address = ff
            End If
        End With
    End With
    If Not x Is Nothing Then
        x.Copy Sheets("Feuil2").Range("a1")
    End If
End Sub

Option Compare Text
Sub test()
  Dim T(), TT(), n As Long, m As Long
  If Application.CountIf([TO[Genre]], "cl") = 0 Then Exit Sub
  T = [To].Value
  f = [To].Rows.Count: ReDim TT(1 To f, 1 To 3)
  If [TC].Item(1, 1) <> "" Then [TC].Delete
  For n = 1 To f
    If T(n, 6) = "cl" And T(n, 3) <> "" Then
      m = m + 1: TT(m, 1) = T(n, 1): TT(m, 2) = T(n, 2): TT(m, 3) = T(n, 3)
    End If
  Next
  [TC[Date]].Resize(m, 3) = TT
End Sub