Macro pour coller transposer un peu spécial

Sub SpecialTranspose()
Dim TableauSouce As Variant
Dim TableauResultat As Variant
Dim i As Long, j As Long, k As Long  'boucle
Dim index As Long

TableauSouce = Worksheets("Feuil1").Range("A1:G3").Value
'initialisation du tableau resultat
index = 1: ReDim TableauResultat(7, 1)
'boucle dans le tableau source pour les recopier
'dans le tableau resultat

For i = 1 To UBound(TableauSouce, 1)
    For j = 5 To 7 'les colonnes contenant les valeurs devant etre sur une nouvelle ligne
        If TableauSouce(i, j) <> "" Then
            'copie des 4 premières colonnes
            For k = 1 To 4
                TableauResultat(k, index) = TableauSouce(i, k)
            Next
            'copie de la valeur en colonne 5
            TableauResultat(5, index) = TableauSouce(i, j)
            'redimensionne le tableau resultat avant de passer à la valeur suivante
            index = index + 1
            ReDim Preserve TableauResultat(7, index)
        End If
    Next
Next
'coller le tableau sur une nouvelle feuille
Worksheets("Feuil2").Range(Cells(1, 1), Cells(index, 7)) = Application.WorksheetFunction.Transpose(TableauResultat)
'un peu de ménage !
Erase TableauSouce
Erase TableauResultat
End Sub