Macro pour coller transposer un peu spécial

[fun]

Bonjour à tous,

je chercher à passer de ça :

Col A ColB ColC ColD ColE ... ColY
L1 M23490 M23490 Charette 2 3 12
L2 M32498 M32498 Camion 5 10 30
... etc

à ça :


Col A ColB ColC ColD
L1 M23490 M23490 Charette 2
L2 M23490 M23490 Charette 3
...
Lw M23490 M23490 Charette 12
Lx M32498 M32498 Camion 5
Ly M32498 M32498 Camion 10
...
Lz M32498 M32498 Camion 30
Etc...

Quelqu'un a une idée???

Merci pour votre aide.😱

 

[Compte Supprimé 979]

Re : Macro pour coller transposer un peu spécial

Salut Fun ...

Tu viens de retrouver ton mot de passe pour ce forum !?

Nous avons l'habitude, ici, de mettre une fichier exemple ...

Au plaisir

 

[zyhack]

Re : Macro pour coller transposer un peu spécial

Bonjour

Un premier jet en passant par des tableaux.

Evidemment le nom des feuilles, des plages de cellules et des valeurs de boucles sont à adapter.

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

bonne journée