Transposer donnees

Y compris Power BI, Power Query et toute autre question en lien avec Excel
Répondre
D
Dehbi
Membre habitué
Membre habitué
Messages : 95
Inscrit le : 30 décembre 2017
Version d'Excel : 2010

Message par Dehbi » 14 octobre 2018, 00:51

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.
transposer.xlsx
(11.48 Kio) Téléchargé 14 fois
M
MFerrand
Fanatique d'Excel
Fanatique d'Excel
Messages : 17'171
Appréciations reçues : 448
Inscrit le : 20 juillet 2015
Version d'Excel : 2010 FR

Message par MFerrand » 14 octobre 2018, 03:26

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"). :mrgreen:

Cordialement.
dehbi_transposer.xlsm
(26.54 Kio) Téléchargé 8 fois
j
jmd
Fanatique d'Excel
Fanatique d'Excel
Messages : 10'599
Appréciations reçues : 250
Inscrit le : 8 décembre 2007
Version d'Excel : 365 + PowerBI

Message par jmd » 14 octobre 2018, 09:53

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 :roll:

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 8[]

note 3 : quel est le BUT de la présentation en lignes ? car elle est particulièrement contraire aux bonnes règles d'informatique.
Copie de transposer.xlsx
(20.28 Kio) Téléchargé 11 fois
Apprenez les fonctions d'Excel.
Exemple "Mettre sous forme de tableau", TCD, "Récupérer des données".
Apprendre les fonctionnalités "récentes".
D
Dehbi
Membre habitué
Membre habitué
Messages : 95
Inscrit le : 30 décembre 2017
Version d'Excel : 2010

Message par Dehbi » 16 octobre 2018, 03:04

Je vous remercie a vous deux de m'avoir eclairés sur ce sujet
Répondre
  • Sujets similaires
    Réponses
    Vues
    Dernier message