Transposition et tri pour créer une liste

Sub Transposition() 'code de MickG, filtrage -> The SoftMama's way
'mixage - ma pomme
Dim Rng As Range, Dn As Range
Dim Lst As Integer
Dim ColRng As Range
Dim Col As Range
Dim c As Integer
Lst = Range("A" & Rows.Count).End(xlUp).Row
Set ColRng = Range("B1", Cells(1, Columns.Count).End(xlToLeft))
ReDim ray(1 To Lst * ColRng.Count, 1 To 6)
 
 For Each Col In ColRng
     Set Rng = Range(Cells(2, Col.Column), Cells(Rows.Count, Col.Column).End(xlUp))
        For Each Dn In Rng
            c = c + 1
            ray(c, 1) = Col
            ray(c, 2) = Cells(Dn.Row, 1)
            ray(c, 3) = Dn
        Next Dn
Next Col
Range("H8").Resize(c, ColRng.Count) = ray
'-> ici commmence le filtrage sans filtre ;-)
Range("H7:J7") = Array("PHASES", "Désignation", "QTE")
With Range("K8:K" & [J65536].End(xlUp).Row)
    .FormulaR1C1 = "=IF(RC[-1]=0,1,"""")"
    .Value = .Value
    .SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
End With
End Sub