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...
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, 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'imageBonjour,
Via un Tableau Croisé Dynamique ?
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 encoreBonjour,
Quelque chose comme ça ?
Bonne journée,
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'ordreBonjour à tous,
Via ce code :
VB: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
est-il possible de copier les en-têtes de colonne dans l'ordre
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