XL 2019 Conversion de plusieurs valeurs de colonnes en lignes

[Dadi147]

Bonjour, aidez-moi s'il vous plaît. J'ai un grand nombre de nombres en double dans une colonne et je veux les convertir en lignes comme sur l'image. Y-a-t-il un moyen de faire ça?
Je veux le copier Sheet2

 

[xUpsilon]

Bonjour,

Via un Tableau Croisé Dynamique ?

Bonne journée,

 

[Dadi147]

Bonjour,

Via un Tableau Croisé Dynamique ?

Bonne journée,

Bonjour, il n'y a pas de table de feuille Excel régulière, je veux juste créer un code vba qui peut extraire ou transférer les valeurs des colonnes C, D, E en lignes comme sur l'image

 

[xUpsilon]

Bonjour,

Quelque chose comme ça ?

Bonne journée,

 

[mapomme]

Bonjour à tous,


Via ce code :

Sub ParLigne()
Dim der, t, ref, nbr&, i&, i1&, i2&
With ActiveSheet
   If .FilterMode Then .ShowAllData
   der = Cells(Rows.Count, "a").End(xlUp).Row
   Columns("a:e").Resize(der).Sort key1:=Range("a1"), order1:=xlAscending, _
         key2:=Range("b1"), order2:=xlAscending, Header:=xlYes
   t = Columns("a:e").Resize(der + 1).Value2
   ReDim r(1 To 1, 1 To Columns.Count - Range("h1").Column - 1)
   Range(Range("h1"), Cells(Rows.Count, Columns.Count)).Clear
   ref = t(2, 1): i1 = 2: i2 = i1: nbr = 1: r(1, nbr) = ref
   Do
      If t(i2, 1) = ref Then
         nbr = nbr + 1: r(1, nbr) = t(i2, 3)
         nbr = nbr + 1: r(1, nbr) = t(i2, 4)
         nbr = nbr + 1: r(1, nbr) = t(i2, 5)
         i2 = i2 + 1
      Else
         Cells(Rows.Count, "h").End(xlUp).Offset(1).Resize(, nbr) = r
         ReDim r(1 To 1, 1 To Columns.Count - Range("h1").Column - 1)
         i1 = i2: i2 = i1: ref = t(i2, 1): nbr = 1: r(1, nbr) = ref
         If ref = "" Then Exit Do
      End If
   Loop
End With

 

[Dadi147]

Bonjour,

Quelque chose comme ça ?

Bonne journée,

Merci de votre intérêt pour le sujet... J'ai essayé, ça répond vraiment aux exigences, mais c'est lent.. Malheureusement, merci encore

 

[Dadi147]

Bonjour à tous,


Via ce code :

Sub ParLigne()
Dim der, t, ref, nbr&, i&, i1&, i2&
With ActiveSheet
   If .FilterMode Then .ShowAllData
   der = Cells(Rows.Count, "a").End(xlUp).Row
   Columns("a:e").Resize(der).Sort key1:=Range("a1"), order1:=xlAscending, _
         key2:=Range("b1"), order2:=xlAscending, Header:=xlYes
   t = Columns("a:e").Resize(der + 1).Value2
   ReDim r(1 To 1, 1 To Columns.Count - Range("h1").Column - 1)
   Range(Range("h1"), Cells(Rows.Count, Columns.Count)).Clear
   ref = t(2, 1): i1 = 2: i2 = i1: nbr = 1: r(1, nbr) = ref
   Do
      If t(i2, 1) = ref Then
         nbr = nbr + 1: r(1, nbr) = t(i2, 3)
         nbr = nbr + 1: r(1, nbr) = t(i2, 4)
         nbr = nbr + 1: r(1, nbr) = t(i2, 5)
         i2 = i2 + 1
      Else
         Cells(Rows.Count, "h").End(xlUp).Offset(1).Resize(, nbr) = r
         ReDim r(1 To 1, 1 To Columns.Count - Range("h1").Column - 1)
         i1 = i2: i2 = i1: ref = t(i2, 1): nbr = 1: r(1, nbr) = ref
         If ref = "" Then Exit Do
      End If
   Loop
End With

Bonjour, vous êtes vraiment super, merci beaucoup .. il y a une dernière question, si vous me le permettez, est-il possible de copier les en-têtes de colonne dans l'ordre
Même si tu n'es pas un génie

 

[mapomme]

Re,

est-il possible de copier les en-têtes de colonne dans l'ordre

Voir fichier joint. Cliquer sur le bouton Hop!

Le code est dans module1:

Sub ParLigne()
Dim der, t, ref, nbr&, i&, i1&, i2&, max&
With ActiveSheet
   If .FilterMode Then .ShowAllData
   der = .Cells(Rows.Count, "a").End(xlUp).Row
   .Columns("a:e").Resize(der).Sort key1:=.Range("a1"), order1:=xlAscending, _
         key2:=.Range("b1"), order2:=xlAscending, Header:=xlYes
   t = .Columns("a:e").Resize(der + 1).Value2
   ReDim r(1 To 1, 1 To .Columns.Count - .Range("h1").Column - 1)
   .Range(.Range("h1"), .Cells(Rows.Count, .Columns.Count)).Clear
   ref = t(2, 1): i1 = 2: i2 = i1: nbr = 1: r(1, nbr) = ref
   Do
      If t(i2, 1) = ref Then
         nbr = nbr + 1: r(1, nbr) = t(i2, 3)
         nbr = nbr + 1: r(1, nbr) = t(i2, 4)
         nbr = nbr + 1: r(1, nbr) = t(i2, 5)
         i2 = i2 + 1
      Else
         If nbr > max Then max = nbr
         .Cells(Rows.Count, "h").End(xlUp).Offset(1).Resize(, nbr) = r
         ReDim r(1 To 1, 1 To .Columns.Count - .Range("h1").Column - 1)
         i1 = i2: i2 = i1: ref = t(i2, 1): nbr = 1: r(1, nbr) = ref
         If ref = "" Then Exit Do
      End If
   Loop
   .Cells(1, "a").Copy .Cells(1, "h")
   .Cells(1, 3).Resize(, 3).Copy .Cells(1, "i").Resize(, max - 1)
End With
End Sub