Transposer donnees

Bonsoir a Tous

Je sollicite votre aide afin de re-organizer mes donnees comme je le souhaite , d'ailleurs je vous joint un fichier sur lequel il y a

le tableau original et en dessous le resultat souhaites. et s'il vous plait en vba

Je vous remercied'avance de votre support.

18transposer.xlsx (11.48 Ko)

Bonsoir,

Sub Dehbi()
    Dim d As Object, clr As Object, k, itm, aa, i%, j%, m%
    Set d = CreateObject("Scripting.Dictionary")
    Set clr = CreateObject("Scripting.Dictionary")
    With ActiveSheet
        aa = .Range("A1").CurrentRegion.Value2
        For i = 2 To UBound(aa)
            k = aa(i, 1) & ";" & aa(i, 2) & ";" & aa(i, 3)
            d(k) = d(k) & ";'" & aa(i, 10)
            If Not clr.exists(aa(i, 2)) Then clr(aa(i, 2)) = .Cells(i, 2).Interior.Color
        Next i
    End With
    k = d.keys: itm = d.items
    For i = 0 To UBound(k)
        k(i) = Split(k(i), ";")
        itm(i) = Replace(itm(i), ";", "", 1, 1): m = UBound(Split(itm(i), ";"))
        j = IIf(m >= j, m + 1, j)
    Next i
    For i = 0 To UBound(k)
        m = UBound(Split(itm(i), ";")) + 1
        Do While m < j
            itm(i) = itm(i) & ";": m = m + 1
        Loop
        itm(i) = Split(itm(i), ";")
    Next i
    With Worksheets("Feuil2")
        .Range("A1").CurrentRegion.Clear
        With .Range("A2").Resize(UBound(k) + 1, 3)
            .Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(k))
            .Columns(1).NumberFormat = "dd-mmm-yy"
            .Columns(2).HorizontalAlignment = xlRight
        End With
        With .Range("D2").Resize(UBound(k) + 1, j)
            .Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(itm))
            .Columns.AutoFit
        End With
        .Range("A1").Resize(, 3).Value = WorksheetFunction.Index(aa, 1, Array(1, 2, 3))
        For i = 1 To j
            .Cells(1, i + 3) = "a" & i
        Next i
        With .Range("A1").CurrentRegion
            With .Rows(1)
                .HorizontalAlignment = xlCenter
                .Interior.Color = RGB(218, 238, 243)
            End With
            For i = 0 To UBound(k)
                .Cells(i + 2, 2).Interior.Color = CLng(clr(.Cells(i + 2, 2).Value))
            Next i
            .Borders.Weight = xlThin
        End With
        .Activate
    End With
End Sub

Tu n'auras pas exactement ce que tu souhaites car 5 types différents au lieu de 3 : "A ", "A", "B ", "B", "C " (et pas de "C").

Cordialement.

bonjour

salut MFerrand

malgré la demande de VBA (étrange qu'on demande d'utiliser une caisse à outils complète alors qu'un tourne-vis standard suffit)

suggestion donc sans VBA, ni aucune formule non plus, ni rien de compliqué

facile à comprendre

facile à faire évoluer

le bonheur

note : j'ai mis des segments dans ton tableau, c'est plus pratique

note 2 : il y a des A non identiques en colonne 2 ! idem pour des B

note 3 : quel est le BUT de la présentation en lignes ? car elle est particulièrement contraire aux bonnes règles d'informatique.

Je vous remercie a vous deux de m'avoir eclairés sur ce sujet

Rechercher des sujets similaires à "transposer donnees"