XL 2010 transformer un tableau pour aligner des données

[michel.dupont]

Bonjour
un exemple vaut mieux qu'une bonne parole!
j'ai un tableau que j'appelle tableau de départ. J'aimerais par macro le transformer de sorte que toutes les données ayant la même entête de colonne puis se positionner l'une à la suite de l'autre.
je pense que mon fichier attaché vous éclairera sur mes intentions!
ma demande se situe dans le cadre de la gestion d'activités pour personnes handicapées mentales
merci par avance de votre aide
Michel

 

[djidji59430]

Re : transformer un tableau pour aligner des données

Bonjour,

comme ceci ?
Quoique je ne comprenne pas bien le deuxieme tableau (repetition des en-tetes)

 

[klin89]

Re : transformer un tableau pour aligner des données

Bonsoir à tous,

Pas trop pigé la finalité, mais bon ...

Option Explicit
Sub test()
Dim a, b(), i As Long, n As Long, e
    a = Sheets("Feuil1").Range("b2").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 2)
            .Item(a(1, i)) = .Item(a(1, i)) + 1
        Next
        ReDim b(1 To Application.Max(.items) + 1, 1 To UBound(a, 2))
        For Each e In .keys
            For i = 1 To .Item(e)
                b(i + 1, n + 1) = a(2, i + n)
                b(1, i + n) = e
            Next
            n = n + .Item(e)
        Next
    End With
    'Restitution et mise en forme
    With Sheets("Feuil2").Range("a1").Resize(UBound(b, 1), UBound(b, 2))
        .Value = b
        .BorderAround Weight:=xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        .Font.Name = "calibri"
        .Font.Size = 10
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        With .Rows(1)
            .WrapText = True
            .Font.Bold = True
            .BorderAround Weight:=xlThin
            .Interior.ColorIndex = 36
        End With
        .Columns.ColumnWidth = 11
        .Parent.Activate
    End With
End Sub

Edit : efface le contenu de la cellule A2 en Feuil1

klin89

 

[michel.dupont]

Re : transformer un tableau pour aligner des données

Merci à tous et en particulier à Klin 89.C'est ce que je voulais merci! Pouvez vous m'aider à finaliser votre code afin de en supprimer les colonnes vides cad qui ne comporte pas de nom en ligne 2.
encore merci
Michel

 

[klin89]

Re : transformer un tableau pour aligner des données

Re michel.dupont,

Je ne comprends pas ceci

afin de supprimer les colonnes vides cad qui ne comporte pas de nom en ligne 2.

Ou alors vous ne souhaitez conserver qu'un seul en-tête.

Option Explicit
Sub test()
Dim a, b(), w(), i As Long, n As Long, maxRow As Long
    a = Sheets("Feuil1").Range("b2").CurrentRegion.Value
    ReDim b(1 To UBound(a, 2) + 1, 1 To 1)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 2)
            If Not .exists(a(1, i)) Then
                n = n + 1
                If n > UBound(b, 2) Then
                    ReDim Preserve b(1 To UBound(b, 1), 1 To n)
                End If
                b(1, n) = a(1, i)
                .Item(a(1, i)) = VBA.Array(1, n)
            End If
            w = .Item(a(1, i))
            w(0) = w(0) + 1
            b(w(0), w(1)) = a(2, i)
            maxRow = Application.Max(maxRow, w(0))
            .Item(a(1, i)) = w
        Next
    End With
    Application.ScreenUpdating = False
    'Restitution et mise en forme
    With Sheets("Feuil2")
        .Cells.Clear
        With .Range("a1").Resize(maxRow, UBound(b, 2))
            .Value = b
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .WrapText = True
                .RowHeight = 30
                .Interior.ColorIndex = 42
                .BorderAround Weight:=xlThin
            End With
            .Columns.ColumnWidth = 11
        End With
        .Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89