transposer un tableau excel

[ricou77]

bonjour,
Pour mon boulot j'aurais besoin de votre aide.
Je dois transposer un tableau excel (voir fichier exemple joint avec tableau de départ et tableau que je souhaiterais). Mon tableau fait un peu plus de 1700 lignes ^^

J'ai déjà essayé avec le collage spécial mais celà ne fonctionne pas comme je voudrais.
J'ai aussi essayé la fonction transpose mais sans succès.

Pourriez-vous m'aider s'il vous plait ?

Merci d'avance
Cordialement

 

[Hippolite]

Re : transposer un tableau excel

Bonjour,
Si tu n'as pas les dernières versions d'Excel, tu es limité à 256 colonnes, tu ne peux donc pas transposer 1700 lignes.
A+

 

[ricou77]

Re : transposer un tableau excel

Bonjour,

En fait je n'ai pas besoin de 1700 colonne ^^
j'ai besoin en tout maximum d'une dizaine de colonnes car toutes les lignes ne doivent pas forcément générer 1 colonne ^^
(voir mon fichier exemple).

Merci

Cordialement

 

[Efgé]

Re : transposer un tableau excel

Bonjour ricou77, Hippolite,
Une proposition, le temps de traitement est à vérifier sur 1 700 lignes .

Private Sub CommandButton1_Click()
Dim D As Object, Plg As Range, Cel As Range, L&, i&
Application.ScreenUpdating = False
L = 1
Set D = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1")
    Set Plg = .Range(.Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp))
    For Each Cel In Plg
        If Not D.Exists(Cel.Value) Then
            L = L + 1
            For i = 0 To 3
                Cells(L, Columns.Count).End(xlToLeft).Offset(0, 1) = _
                Cel.Offset(0, i).Value
            Next i
        Else
            For i = 1 To 3
                Cells(L, Columns.Count).End(xlToLeft).Offset(0, 1) = _
                Cel.Offset(0, i).Value
            Next i
        End If
        D(Cel.Value) = Cel.Value
    Next Cel
End With
Application.ScreenUpdating = False
End Sub

Cordialement

 

[Softmama]

Re : transposer un tableau excel

Bonjour,

Avec une autre façon de faire, avec la colonne A préalablement classée par matricule :

Sub test()
Dim c As Range, t As Integer

Application.ScreenUpdating = False
Set c = Range("A3")
Do While c(2, 1) <> ""
  If c(2, 1) = c Then
    c.Offset(1, 1).Resize(, 3).Copy Cells(c.Row, 256).End(xlToLeft)(1, 2)
    c(2, 1).EntireRow.Delete
  Else
    Set c = c(2, 1)
  End If
Loop
t = 5
Do While Application.WorksheetFunction.CountA(Columns(t)) > 0
  Cells(2, t) = Cells(2, (t - 2) Mod 3 + 2).Text & Int((t - 2) / 3)
  t = t + 1
Loop
Application.ScreenUpdating = True
End Sub

cf. fichier joint

 

[ricou77]

Re : transposer un tableau excel

Bonjour,

Un très très grand merci à vous 2.
Vous m'avez enlevé une grosse épine du pied.
Vous devriez être déclarés d'utilité publique ^^.

Je ne connais pas encore le language VBA mais je crois que je vais m'y mettre ^^.

Merci encore

Cordialement

 

[Efgé]

Re : transposer un tableau excel

Re à tous, Bonjour Softmama,
ricou77 semble avoir trouvé chaussure à son pied, mais comme je l'ai fait:
Une version un peu plus rapide que ma proposition précédente et sans que les matricules soient triés:

Private Sub CommandButton1_Click()
Dim D As Object, Plg As Range, Cel As Range, Temp As Variant, L&, i&
Application.ScreenUpdating = False
L = 1
Set D = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1")
    Set Plg = .Range(.Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp))
    For Each Cel In Plg
        If Not D.Exists(Cel.Value) Then
            L = L + 1
            Temp = .Range(Cel.Address, Cel.Offset(0, 3).Address).Value
            Cells(L, Columns.Count).End(xlToLeft).Offset(0, 1).Resize(1, 4) = Temp
            D(Cel.Value) = L
        Else
            Temp = .Range(Cel.Offset(0, 1).Address, Cel.Offset(0, 3).Address).Value
            Cells(D(Cel.Value), Columns.Count).End(xlToLeft).Offset(0, 1).Resize(1, 3) = Temp
        End If
    Next Cel
End With
Application.ScreenUpdating = True
End Sub

Cordialement

Edit: Le même en plus dense et un peu plus rapide:

Private Sub CommandButton2_Click()
Dim D As Object, Plg As Range, Cel As Range, L%
Application.ScreenUpdating = False
Set D = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1")
    Set Plg = .Range(.Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp))
    For Each Cel In Plg
        L = 1
        If Not D.Exists(Cel.Value) Then
            D(Cel.Value) = D.Count + 2
            L = 0
        End If
        Cells(D(Cel.Value), Columns.Count).End(xlToLeft).Offset(0, 1).Resize(1, 4 - L) = _
        .Range(Cel.Offset(0, L).Address, Cel.Offset(0, 3).Address).Value
    Next Cel
End With
Application.ScreenUpdating = True
End Sub

Cordialement

 

[ricou77]

Re : transposer un tableau excel

merci quand même ^^