VBA_ créer une nouvelle feuille et y ventiller des données dans des onglets

Le 19/09/2023 à 18:24

Bonjour à tous ,

J'ai à nouveau besoin de votre aide car je suis vraiment trop débutante pour comprendre le code de Mferrand et l'adapter ...( un jour peut être .. )

J'aimerais à partir du tableau (ci dessous)

image

, créer un nouveau classeur excel , et y ventiler les données du tableau, avec un onglet pour chaque identifiant de la colonne "T" .

Je vous joint mon fichier et le code que j'essaie d'adapter .

CODE DE MFERRAND : 

Sub Ventilation()
    Dim plgET As Range, d1 As Object, d2 As Object, n&, i&, j&
    Dim k, kk, klg, wsS, chD$, Llg()
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    With ActiveSheet
        n = .Cells(.Rows.Count, 14).End(xlUp).Row
        Set plgET = .Range("A1").Resize(9, 51)
        wsS = .Range("A1:AY" & n)
    End With
    For i = 10 To n
        k = wsS(i, 14): kk = wsS(i, 15)
        If InStr(1, d1(k), kk) = 0 Then d1(k) = d1(k) & ";" & kk
        d2(k & kk) = d2(k & kk) & ";" & i
    Next i
    chD = ThisWorkbook.Path & "\"
    Application.ScreenUpdating = False
    For Each k In d1.keys
        kk = Split(d1(k), ";"): n = UBound(kk)
        With Workbooks.Add(xlWBATWorksheet)
            .SaveAs chD & k & ".xlsx", xlOpenXMLWorkbook
            If n > 1 Then .Worksheets.Add after:=Worksheets(1), Count:=n - 1
            For i = 1 To n
                With .Worksheets(i)
                    .Name = kk(i)
                    With .Cells.Font
                        .Name = "Arial": .Size = 7
                    End With
                    plgET.Copy
                    With .Range("A1")
                        .PasteSpecial xlPasteAll
                        .PasteSpecial xlPasteColumnWidths
                    End With
                    .Activate: .Range("A1").Select
                    klg = Split(d2(k & kk(i)), ";")
                    ReDim Llg(1 To UBound(klg))
                    For j = 1 To UBound(klg)
                        Llg(j) = WorksheetFunction.Index(wsS, CLng(klg(j)), 0)
                    Next j
                    With .Range("A10:AY" & UBound(klg) + 9)
                        .Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Llg))
                        .Borders.Weight = xlThin
                    End With
                End With
            Next i
            .Worksheets(1).Activate
            .Close True
        End With
    Next k
End Sub
12consignes-fdr.xlsm (28.88 Ko)

Merci de m'avoir lu et bonne journée à tous !

A

Le 20/09/2023 à 06:09

Bonjour Anais, voici le code il fonctionne mais il y a surement 1 truc a changer pour avoir les couleurs de fond, le code est a corriger, mais tu as la base pour ta demande. Et peu être avoir juste le tableau copié de A11 à I11 en A1 dans les nouveaux classeurs crées.

Sub VentilationSingleTab()
    ' Déclaration des variables
    Dim plgET As Range, d1 As Object, d2 As Object, n&, i&, j&
    Dim k, kk, klg, wsS, chD$, Llg()

    ' Création de deux dictionnaires pour stocker les données
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")

    ' Définition de la plage de travail et des données
    With ActiveSheet
        n = .Cells(.Rows.Count, 6).End(xlUp).Row
        ' Plage de A1 à I11 (11 lignes et 9 colonnes)
        Set plgET = .Range("A1").Resize(11, 9)
        wsS = .Range("A1:I" & n) ' Plage de A1 à I(n)
    End With

    ' Boucle pour traiter les données
    For i = 12 To n
        k = wsS(i, 6) ' Valeur de la colonne F (colonne 6)
        If InStr(1, d1(k)) = 0 Then d1(k) = d1(k) & ";" ' Stocke les valeurs uniques dans d1
        d2(k) = d2(k) & ";" & i ' Stocke les numéros de ligne associés à chaque valeur dans d2
    Next i

    ' Chemin où les nouveaux classeurs seront enregistrés
    chD = ThisWorkbook.Path & "\"

    ' Désactivation de la mise à jour de l'écran pour accélérer le traitement
    Application.ScreenUpdating = False

    ' Boucle pour créer les nouveaux classeurs
    For Each k In d1.Keys
        ' Crée un nouveau classeur Excel
        With Workbooks.Add(xlWBATWorksheet)
            ' Enregistre le classeur avec un nom basé sur la valeur k
            .SaveAs chD & k & ".xlsx", xlOpenXMLWorkbook

            ' Travaille sur la première feuille du nouveau classeur
            With .Worksheets(1)
                .Name = k ' Nomme la feuille avec la valeur k
                ' Paramètres de la police pour la feuille
                With .Cells.Font
                    .Name = "Calibri"
                    .Size = 11
                End With
                ' Copie la plage plgET dans A1 du nouveau classeur
                plgET.Copy
                .Range("A1").PasteSpecial xlPasteAll
                .Range("A1").PasteSpecial xlPasteColumnWidths
                ' Active la cellule A1
                .Activate: .Range("A1").Select
                ' Récupère les numéros de ligne associés à la valeur k
                klg = Split(d2(k), ";")
                ReDim Llg(1 To UBound(klg))
                For j = 1 To UBound(klg)
                    ' Remplit Llg avec les données de la feuille d'origine
                    Llg(j) = WorksheetFunction.Index(wsS, CLng(klg(j)), 0)
                Next j
                ' Copie les données de Llg dans la plage A12:I(xx)
                With .Range("A12:I" & UBound(klg) + 11)
                    .Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Llg))
                    .Borders.Weight = xlThin ' Ajoute des bordures légères
                End With
            End With
            .Worksheets(1).Activate
            .Close True ' Ferme le nouveau classeur en l'enregistrant
        End With
    Next k

    ' Réactive la mise à jour de l'écran
    Application.ScreenUpdating = True
End Sub

corriger

Le 20/09/2023 à 09:34

Bonjour Stepaustras,

Merci beaucoup d'avoir adapté le code pour moi et pour la traduction c'est vraiment génial :D !

Bonne journée à toi et à vous tous !

Le 20/09/2023 à 13:03

Re voici le code remanié il te copie les données juste du tableau de A11:I11 et colle en A1 dans les nouveaux classeurs en conservant le format des cellules.

Sub VentilationSingleTab()
    ' Déclaration des variables
    Dim plgET As Range, d1 As Object, d2 As Object, n&, i&, j&
    Dim k, klg, wsS, chD$, Llg()

    ' Création de deux dictionnaires pour stocker les données
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")

    ' Définition de la plage de travail et des données
    With ActiveSheet
        n = .Cells(.Rows.Count, 6).End(xlUp).Row
        ' Plage de A11 à I11 (10 lignes et 9 colonnes)
        Set plgET = .Range("A11:I11").Resize(10, 9)
        wsS = .Range("A1:I" & n) ' Plage de A1 à I(n)
    End With

    ' Boucle pour traiter les données
    For i = 12 To n
        k = wsS(i, 6) ' Valeur de la colonne F (colonne 6)
        If InStr(1, d1(k)) = 0 Then d1(k) = d1(k) & ";" ' Stocke les valeurs uniques dans d1
        d2(k) = d2(k) & ";" & i ' Stocke les numéros de ligne associés à chaque valeur dans d2
    Next i

    ' Chemin où les nouveaux classeurs seront enregistrés
    chD = ThisWorkbook.Path & "\"

    ' Désactivation de la mise à jour de l'écran pour accélérer le traitement
    Application.ScreenUpdating = False

    ' Boucle pour créer les nouveaux classeurs
    For Each k In d1.Keys
        ' Crée un nouveau classeur Excel
        With Workbooks.Add(xlWBATWorksheet)
            ' Enregistre le classeur avec un nom basé sur la valeur k
            .SaveAs chD & k & ".xlsx", xlOpenXMLWorkbook

            ' Travaille sur la première feuille du nouveau classeur
            With .Worksheets(1)
                .Name = k ' Nomme la feuille avec la valeur k
                ' Paramètres de la police pour la feuille
                With .Cells.Font
                    .Name = "Calibri"
                    .Size = 11
                End With
                ' Copie la plage plgET dans A1 du nouveau classeur
                plgET.Copy
                .Range("A1").PasteSpecial xlPasteAll
                .Range("A1").PasteSpecial xlPasteColumnWidths
                ' Active la cellule A1
                .Activate: .Range("A1").Select
                ' Récupère les numéros de ligne associés à la valeur k
                klg = Split(d2(k), ";")
                ReDim Llg(1 To UBound(klg))
                For j = 1 To UBound(klg)
                    ' Remplit Llg avec les données de la feuille d'origine
                    Llg(j) = WorksheetFunction.Index(wsS, CLng(klg(j)), 0)
                Next j
                ' Copie les données de Llg dans la plage A2:I(xx)
                .Range("A2:I" & UBound(klg) + 1).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Llg))
                .Range("A2:I" & UBound(klg) + 1).Borders.Weight = xlThin ' Ajoute des bordures légères
            End With
            .Worksheets(1).Activate
            .Close True ' Ferme le nouveau classeur en l'enregistrant
        End With
    Next k

    ' Réactive la mise à jour de l'écran
    Application.ScreenUpdating = True
End Sub
Rechercher des sujets similaires à "vba creer nouvelle feuille ventiller donnees onglets"