Microsoft 365 Vba : copier certaines cellules suivant la valeur d'une autre

Sub Lister()
Dim t, der As Long, i As Long, j As Long, n As Long
   With Sheets("Feuil1").UsedRange                       ' avec la plage utile de la feuille Feuil1
      t = .Range("a1").Resize(.Row + .Rows.Count, .Column + .Columns.Count)   ' lecture des valeurs
   End With
 
   For der = 3 To UBound(t, 2)         ' recherche de la première colonne vide après les noms de la ligne 4
      If t(4, der) = "" Then Exit For  ' une cellule vide a été détectée => on quitte la boucle
   Next der
   der = der - 1                                ' la dernière colonne des noms
   ReDim v(1 To UBound(t) * (der - 2), 1 To 3)  ' le tableau r contenant les valeurs résultats

   For i = 7 To UBound(t)           ' boucle sur les lignes de t à partir de la ligne 7
      If Trim(t(i, 1)) <> "" Then   ' si le paramètre n'est pas vide alors
         For j = 3 To der           ' on boucle sur les colonnes des noms
            ' si la valeur de la colonne n'est pas vide, on ajoute la valeur dans le tableau résultat
            If Trim(t(i, j)) <> "" Then n = n + 1: v(n, 1) = t(i, 1): v(n, 2) = t(i, 2): v(n, 3) = t(4, j)
         Next j
      End If
   Next i
 
   With Sheets("Feuil2")                                       ' affichage sur la feuille "Feuil2"
      .Range(.Cells(4, "a"), .Cells(.Rows.Count, "c")).Clear   ' effacement des précédent résultats
      If n > 0 Then .Cells(4, "a").Resize(n, 3) = v            ' si v comporte au moins une ligne, on l'affiche
      .Select                                                  ' sélection de la feuille "Feuil2"
   End With
End Sub