Multiplication d'un tableau en plusieurs tableaux

Re,

Quelles explications souhaites-tu ?

Le travail est exécutée par une procédure VBA

Pour visualiser la procédure :

ALT 11 pour ouvrir l'éditeur VBE

Voir Module1

Option Explicit

Public Sub CopyPivotPages()
Dim wb As Workbook, ws As Worksheet, ws2 As Worksheet
Dim pt As PivotTable, pf As PivotField, pi As PivotItem
Dim lRow As Long

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    Set wb = ActiveWorkbook
    Set ws = wb.Worksheets("TCD Général")
    Set pt = ws.PivotTables(1)
    Set pf = pt.PageFields(1)

    lRow = 1
    pf.ClearAllFilters

    On Error Resume Next
    Worksheets("Liste Plats").Delete
    On Error GoTo 0

    Application.DisplayAlerts = True

    Set ws2 = wb.Worksheets.Add
    ws2.Name = "Liste Plats"

    For Each pi In pf.PivotItems
        With pf
            .PivotItems(pi.Name).Visible = True
            .CurrentPage = pi.Name
        End With
        With ws2.Cells(lRow, 1)
            .Value = pi.Name
            .Font.Bold = True
        End With
        pt.TableRange1.Copy
        With ws2.Cells(lRow + 1, 1)
            .PasteSpecial xlPasteValuesAndNumberFormats
            .PasteSpecial xlPasteFormats
            .PasteSpecial xlPasteColumnWidths
        End With
        Application.CutCopyMode = False
        lRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 2
    Next pi

    ActiveWindow.DisplayGridlines = False

    pf.ClearAllFilters

End Sub

J'ai essayé de faire le plus simple possible avec une solution de filtrage

Private Sub Worksheet_Activate()
Dim cel As Range
decalage = 0

For Each cel In Sheets("Plats").Range("plats[Plats]")
    Range("A2").Offset(, decalage).Value = cel.Value

    Sheets("Tableau_général").Range("donnees[#All]").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=Range("A1:A2").Offset(, decalage), _
    CopyToRange:=Range("A4:F4").Offset(, decalage), _
    Unique:=False

    decalage = decalage + 7
Next

End Sub

Reste juste à établir par Scripting.Dictionary comme proposé par Klin la liste des plats (si nécessaire)

Re

La grande question est de savoir quelle est la forme du tableau source : en liste de données comme le 1er exemple fourni ou à double entrée comme le second...

Ah je n'avais pas vu cette subtilité

Si la demande évolue ...

Bonjour à tous,

Je viens de tester vos fichiers et cela a résolu mon problème avec des modifications que j'ai pu faire.

Je vous remercie.

Le sujet est donc, clos.

Storm28

re le forum

Avec le filtre automatique

Option Explicit
Sub test()
Dim a, e, dico As Object, n As Long
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    Sheets("Feuil3").Cells.Delete: n = 1
    With Sheets("Tableau_générale")
        With .Range("a3").CurrentRegion
            a = .Columns(6).Offset(1).Resize(.Rows.Count - 1).Value
            For Each e In a
                If Not dico.exists(e) Then
                    dico(e) = Empty
                    .AutoFilter 6, e
                    .SpecialCells(xlCellTypeVisible).Copy Sheets("Feuil3").Cells(1, n)
                    With Sheets("Feuil3").Cells(1, n).CurrentRegion
                        .BorderAround Weight:=xlThin
                        .Borders(xlInsideVertical).Weight = xlThin
                        With .Rows(1)
                            .Font.Size = 12
                            .Interior.ColorIndex = 44
                            .BorderAround Weight:=xlThin
                        End With
                        .Columns(6).AutoFit
                    End With
                    .AutoFilter: n = n + 7
                End If
            Next
        End With
    End With
    Set dico = Nothing
    Sheets("Feuil3").Activate
    Application.ScreenUpdating = True
End Sub

klin89