XL 2013 Regrouper des Onglets pour créer un nouveau fichier

[don_pets]

Salut le fofo,

Avant toute chose, je vous souhaite une belle et heureuse année.

Bien que le titre ait l'air simple dans sa résolution ma demande est assez complexe, je vais tâcher d'être simpliste et minimaliste dans mon explication.

J'ai un tableau avec disons plusieurs gestionnaires pour plusieurs types d'extractions But du jeu : créer un fichier spécifique à chaque user avec autant d'onglets qu'il a de type d'extractions

Pour illustrer : imaginons le tableau avec les colonnes A : pour Gestionnaire genre JeanMiche, Gaston, etc ..., de B à w de la donnée on s'en fout, et en X une colonne dédiée à un type d'extraction genre Extraction A, Extraction B, etc...

Je souhaiterai avoir en rendu final un xlsx Gaston avec dedans les onglets ExtractionA, ExtractionB, etc., un fichier xlsx JeanMiche avec vec dedans les onglets ExtractionA, ExtractionB,

Voilà ça c'est le topo.

Pour l'instant j'arrive à créer sur mon fichier autant d'onglets qu'il y a de gestionnaires et de type d'extraction que je nomme disons "JeanMiche ExtractionA", "JeanMiche ExtractionB" etc. Là où je bloque c'est pour regrouper les onglets de chaque user pour les save sur un fichier spécifique.

Mon code actuel :

Dim rngList As Range, rngData As Range, rngCriteria As Range, r As Long
Dim rngList2 As Range, rngData2 As Range, rngCriteria2 As Range, r2 As Long
Dim Chemin As String

Application.ScreenUpdating = False

    With Sheets("data")
        Set rngData = .Range("A1").CurrentRegion
    End With
 
    With Sheets("Temp")
        Set rngList = .Range("A1"): Set rngCriteria = .Range("C1:C2")
    End With

    With rngData
        .Resize(, 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngList, Unique:=True
    End With

For r = 1 To rngList.CurrentRegion.Rows.Count - 1
    rngCriteria.Cells(2, 1) = rngList.Offset(r)
    Sheets.Add before:=Sheets(1): Sheets(1).Name = rngList.Offset(r)
        With rngData
            .AdvancedFilter xlFilterCopy, rngCriteria, Sheets(1).Range("A1")
        End With
        
        Application.CutCopyMode = False
                With Sheets(1)
                    .Columns("w:w").Cut
                    .Columns("A:A").Insert Shift:=xlToRight
                    Set rngData2 = .Range("A1").CurrentRegion
                End With
        
                With Sheets("Temp")
                    Set rngList2 = .Range("E1"): Set rngCriteria2 = .Range("G1:G2")
                End With
        
                With rngData2
                    .Resize(, 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngList2, Unique:=True
                End With
        
                For r2 = 1 To rngList2.CurrentRegion.Rows.Count - 1
                    rngCriteria2.Cells(2, 1) = rngList2.Offset(r2)
                    Sheets.Add before:=Sheets(1): Sheets(1).Name = rngList.Offset(r) & " " & rngList2.Offset(r2)
                
                With rngData2
                    .AdvancedFilter xlFilterCopy, rngCriteria2, Sheets(1).Range("A1")
                End With
                
                With Sheets(1)
                    .Range("a1").CurrentRegion.RowHeight = 18
                End With
                
                With Sheets(1)
                    .Range("A1").Select
                    Sheets(1).ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = _
                        "Liste_Sinistre"
                End With
                
                Next
    Sheets(rngList.Offset(r)).Select
    'Sheets(1).Move
    'Sheets(1).Columns("a:e").AutoFit
Next
Application.ScreenUpdating = True

je partais dans l'idée de faire un truc dans ce goût là

Sheets(Array("Feuil1", "Feuil2")).Copy

    With ActiveWorkbook
        .SaveAs Filename:=Chemin & " " & "Nom" & " " & Format(Now, "yy-mm-dd hhmmss")
        .Close
    End With

mais je me prends la tête depuis hier et je me dis que ce serait bien d'avoir un oeil neuf. Ca manque d'expert VB à côté de moi, me sens un peu seul ...

Merci par avance les amis et n'hésitez pas à me conspuer si je ne suis pas très explicit dans mon expression de besoin

 

[kiki29]

Salut, pour info ou mieux ceci

 

[don_pets]

Hello Kiki,

Merci pour ton retour mais la solution que tu envoies ne me saute pas aux yeux. Si je comprends bien tes macros permettent de fusionner les feuilles que tu sélectionnes en pdf.

Pour ma part, je cherche un moyen de regrouper automatiquement les onglets par nom de collaborateur.

Néanmoins je te remercie pour ton retour

 

[don_pets]

Je re-up si jamais quelqu'un a une autre idée