XL 2016 Méthode rapide pour mettre cellules dans variable tableau

Sub Bruno()
Dim Tbl
Dim Tbl2()
Dim I As Long, J As Long
Dim K As Byte
T = Timer
With Sheets("DA")
    Tbl = .Range("A7:Q" & .Cells(Rows.Count, "F").End(xlUp).Row)
    For I = LBound(Tbl) To UBound(Tbl)
        If Tbl(I, 8) <> 0 Then
            ReDim Preserve Tbl2(3, J)
            For K = 0 To 3
                Tbl2(K, J) = Tbl(I, 5 + K)
            Next K
            J = J + 1
        End If
    Next I
End With
Tbl2 = Application.Transpose(Tbl2)
Sheets("Résultat").Range("K1").Resize(UBound(Tbl2), 4).Value = Tbl2
MsgBox Timer - T
End Sub

Sub Test_3()
  Dim Sht As Worksheet
  Dim dLig As Long, Lig As Long, i As Long
  Dim Inc As Long, NbQt As Long
  Dim Col As Integer
  Dim dCol As Byte
  Dim Tablo
  Set Sht = ThisWorkbook.Sheets("DA")
  Inc = 0
  dLig = Sht.Cells(Sht.Rows.Count, 6).End(xlUp).Row
  If dLig = 6 Then Exit Sub 'si plage de données vide on quitte
  dCol = Sht.Cells(4, Sht.Columns.Count).End(xlToLeft).Column
  Tablo = Sht.Range(Sht.Cells(7, 1), Sht.Cells(dLig, dCol))
  ' Pour chaque ligne du tableau
  For Lig = 1 To UBound(Tablo)
    If Tablo(Lig, 8) <> 0 Then
      ' Incrémenter le nombre de quantité
      Inc = Inc + 1
      For i = 1 To 4
        Tablo(Inc, i) = Tablo(Lig, i + 4)
        Next i
    End If
  Next Lig
     If Inc = 0 Then Exit Sub 'Si pas de retour On quitte
  ' Résultat

    Sheets("Résultat").Range("A1").Resize(Inc, 4) = Tablo
 
End Sub

Sub test2()
    Dim p As Range, Pc As Range, tablo(), Lig&, A&, C&
    'on détermine la plage a copier E:H avec les ligne vide en "H"
    Set p = Sheets("DA").Range("E" & 7, Sheets("DA").Cells(Rows.Count, "H").End(xlUp))
    ' on determine la plage (colonne"H" avec uniquement les cellule pleines
    Set Pc = p.Columns(4).SpecialCells(xlCellTypeConstants)
    'le nombre de cellule pleines  de la colonne"H" sera donc le nombre de ligne  à  boucler
    nblig = Pc.Cells.Count
    ' on crée donc la variable tableau avec le nombre de ligne et 4  colonnes
    ReDim tablo(1 To nblig, 1 To 4)
    'MsgBox Pc.Cells.Count 'juste pour controler
    'ici on boucle donc sur (seulement les cells  de Pc (qui on un nombre  )
    For Each cel In Pc.Cells
        Lig = cel.Row    'on detrmine  donc la ligne de cette cells
        A = A + 1    'on incrémente  pour le tableau
        'on boucle sur les 4  colonnes
        For C = 1 To 4
            tablo(A, C) = Sheets("DA").Cells(Lig, C + 4)    'on inscrit les valeurs
        Next
    Next
    'on envoie tout ça dans le sheets("Résultat") en [A1]
    Sheets("Résultat").Range("A1").Resize(UBound(tablo), 4).Value = tablo
End Sub

Sub test2()
Application.ScreenUpdating = False

Dim TabData() As Variant
Dim Fin As Long
Dim i, j As Long
With Sheets("DA")
    Fin = .UsedRange.Rows.Count
    TabData = .Range("A4:Q" & Fin).Value
End With
For i = LBound(TabData, 1) To UBound(TabData, 1)
    If TabData(i, 8) = "" Then
        For j = LBound(TabData, 2) To UBound(TabData, 2)
            TabData(i, j) = ""
        Next j
    End If
Next i

With Sheets("Résultat")
    .Range("A1").Resize(UBound(TabData, 1), UBound(TabData, 2)) = TabData
    .Range("A1").Resize(UBound(TabData, 1), UBound(TabData, 2)).Columns(8).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Union(.Columns("A:D"), .Columns("I:Q")).Delete
End With
Application.ScreenUpdating = True

End Sub

Sub test3()
    Dim Tbl
    Dim lignes()
    Dim I As Long, J As Long
    Dim K As Byte
    T = Timer
    With Sheets("DA")
        Tbl = .Range("A7:Q" & .Cells(Rows.Count, "F").End(xlUp).Row)
        For I = LBound(Tbl) To UBound(Tbl)
            If Tbl(I, 8) <> 0 Then a = a + 1: ReDim Preserve lignes(1 To a): lignes(a) = I
        Next I
    End With
    tabl = Application.Index(Tbl, Application.Transpose(lignes), Array(5, 6, 7, 8))

    Sheets("Résultat").Range("K1").Resize(UBound(tabl), 4).Value = tabl
    MsgBox Timer - T
End Sub