Tableau dynamique à partir de deux tableaux

Bonjour,

je joint un fichier sur lequel je met en l'état deux tableaux que l'on me transmet. Ils sont sur ma feuill1.

Sachant que l'on retrouvera forcement tous les noms du tableau de gauche (le plus gros) dans le tableau de droite. Parcontre le tableau de droite peut avoir des noms en plus (c'est le cas dans mon exemple avec PAUL MOY, PATRICIA POT, MIREILLE DOL et FRANCK JU

en plus).

Mon but est de trouver la manière la plus efficace et plus rapide de faire un condensé des deux tableaux. Dans le style de tableau que j'ai mis en feuill3. Soit de façon dynamique ou par macro. Quel que soit le nombre de nom dans les tableau je voudrais automatiser tout ça car actuellement je perd énormément de temps

Vous pourriez me dire que les tableaux de ma feuill1 sont mal conçu, effectivement, malheureusement il m'est obligatoire de composer avec ça, ils auront tjs la même forme, la seule donnée qui change est le nombre de nom d'Agent.

Si quelqu'un pouvais m'aider ça serait génial

par avance merci

bonne soirée

Eno

Bonsoir Eno83,

A tester :

Restitution en Feuil2.

Option Explicit
Sub test()
Dim a, b(), i As Long, j As Long, n As Long
    With Sheets("Feuil1").Range("a12").CurrentRegion
        a = .Value: n = 2
        'Attention à la 1ère dimension
        ReDim b(1 To 100, 1 To 13)
        For i = 1 To UBound(a, 2)
            b(n, i) = a(1, i)
        Next
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1) - 2
                If a(i, 1) = "" Then a(i, 1) = a(i - 1, 1)
                If Not .exists(a(i, 1)) Then
                    n = n + 2
                    For j = 1 To 9
                        b(n - 1, j) = a(i, j)
                    Next
                    .Item(a(i, 1)) = n
                Else
                    For j = 2 To 9
                        b(.Item(a(i, 1)), j) = a(i, j)
                    Next
                End If
            Next
            a = Sheets("Feuil1").Range("m12").CurrentRegion.Value
            b(1, 10) = a(1, 2): b(1, 12) = a(1, 4)
            For i = 2 To UBound(a, 2)
                b(2, i + 8) = a(2, i)
            Next
            For i = 3 To UBound(a, 1) - 1
                If .exists(a(i, 1)) Then
                    For j = 2 To UBound(a, 2)
                        b(.Item(a(i, 1)) - 1, j + 8) = a(i, j)
                    Next
                Else
                    n = n + 1
                    b(n, 1) = a(i, 1)
                    For j = 2 To UBound(a, 2)
                        b(n, j + 8) = a(i, j)
                    Next
                End If
            Next
            n = n + 2
            b(n - 1, 1) = "Total"
            b(n - 1, 2) = "Manuel": b(n, 2) = "Vérification des réponses"
        End With
    End With
    Application.ScreenUpdating = False
    'Restitution
    With Sheets("Feuil2").Cells(1).Resize(n, UBound(b, 2))
        .CurrentRegion.Clear
        .Value = b
        .Font.Name = "calibri"
        .Font.Size = 10
        .VerticalAlignment = xlCenter
        With .Offset(1).Resize(.Rows.Count - 1)
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Columns(1).HorizontalAlignment = xlCenter
            With .Rows(1)
                .VerticalAlignment = xlTop
                .HorizontalAlignment = xlCenter
                .Interior.ColorIndex = 36
                .RowHeight = 39
                .BorderAround Weight:=xlThin
            End With
        End With
        .Columns.AutoFit
        With .Rows(1).Offset(, 9).Resize(, .Columns.Count - 9)
            .Interior.ColorIndex = 36
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            .Cells(1).Resize(, 2).HorizontalAlignment = xlCenterAcrossSelection
            .Cells(3).Resize(, 2).HorizontalAlignment = xlCenterAcrossSelection
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour Klin!

Je viens de tester et ça me convient parfaitement

Je te remercie pour le temps passé à m aider

Bonne fin de journée

Re Eno83

Comme ceci, le rendu est similaire au résultat souhaité.

Option Explicit
Sub Test()
Dim a, b(), i As Long, j As Long, n As Long, w(), z(), x, y
    a = Sheets("Feuil1").Range("m12").CurrentRegion.Value
    ReDim b(1 To 2, 1 To 13)
    b(1, 10) = a(1, 2): b(1, 12) = a(1, 4): b(2, 10) = a(2, 2)
    b(2, 11) = a(2, 3): b(2, 12) = a(2, 4): b(2, 13) = a(2, 5)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 3 To UBound(a, 1) - 1
            ReDim w(1 To 2): ReDim z(1 To 13, 1 To 1)
            z(1, 1) = a(i, 1)
            For j = 2 To UBound(a, 2)
                z(j + 8, 1) = a(i, j)
            Next
            w(1) = False: w(2) = z
            .Item(a(i, 1)) = w
        Next
        a = Sheets("Feuil1").Range("a12").CurrentRegion.Value
        For i = 1 To UBound(a, 2): b(2, i) = a(1, i): Next
        For i = 2 To UBound(a, 1) - 2
            If a(i, 1) = "" Then a(i, 1) = a(i - 1, 1)
            If .exists(a(i, 1)) Then
                w = .Item(a(i, 1))
                z = w(2)
                If w(1) = False Then
                    w(1) = True
                Else
                    ReDim Preserve z(1 To 13, 1 To UBound(z, 2) + 1)
                End If
                For j = 2 To 9
                    z(j, UBound(z, 2)) = a(i, j)
                Next
                w(2) = z
                .Item(a(i, 1)) = w
            End If
        Next
        x = .keys: y = .items
    End With
    Application.ScreenUpdating = False
    'Restitution et mise en forme
    With Sheets("Feuil2").Cells(1)
        .Parent.Cells.Clear
        .Resize(UBound(b, 1), UBound(b, 2)).Value = b
        n = 2
        For i = 0 To UBound(x)
            With .Offset(n).Resize(UBound(y(i)(2), 2), UBound(y(i)(2), 1))
                .Value = Application.Transpose(y(i)(2))
                If y(i)(1) = True Then
                    .Columns(1).MergeCells = True
                    For j = 10 To 13
                        .Columns(j).MergeCells = True
                    Next
                Else
                    .Rows.Interior.ColorIndex = 40
                End If
                .BorderAround Weight:=xlMedium
                .Borders(xlInsideHorizontal).Weight = xlThin
                n = n + .Rows.Count
            End With
        Next
        With .CurrentRegion
            .Font.Name = "calibri": .Font.Size = 10
            .VerticalAlignment = xlCenter
            With .Rows(1).Offset(, 9).Resize(, .Columns.Count - 9)
                .RowHeight = 39: .Interior.ColorIndex = 36
                .WrapText = True: .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .Cells(1).Resize(, 2).HorizontalAlignment = xlCenterAcrossSelection
                .Cells(3).Resize(, 2).HorizontalAlignment = xlCenterAcrossSelection
            End With
            With .Rows(2)
                .RowHeight = 45: .Interior.ColorIndex = 36
                .WrapText = True: .BorderAround Weight:=xlMedium
            End With
            With .Offset(1).Resize(.Rows.Count - 1)
                .Borders(xlInsideVertical).Weight = xlMedium
            End With
            With .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2)
                .HorizontalAlignment = xlCenter
            End With
            .Columns.ColumnWidth = Array(14, 24, 11, 11, 11, _
                                         11, 11, 11, 11, 11, 11, 11, 11)
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Coucou, merci!!

Parfait

Merci pour ton aide

Bonne journée

Rechercher des sujets similaires à "tableau dynamique partir deux tableaux"