Microsoft 365 Scinder un tableau en X fichiers contenant Y Onglets

[ldesevin]

Bonjour à tous,
J'ai un tableau excel de 6000 lignes et 10 colonnes.
Je souhaiterais communiquer une partie de ce tableau à différentes personnes, et donc le scinder.
En colonne C, j'ai une info qui doit servir à la séparation des classeurs (pour chaque valeur unique je dois obtenir un nouveau classeur, +/- 80 valeurs uniques), et dans chacun de ces classeurs c'est la valeur de la colonne D qui doit permettre de séparer les données dans 4 onglets différents (il n'y a que 4 valeurs possibles)
J'ai épluché les forum mais ma compréhension du VBA ne m'a pas permis de m'en sortir, j'espère donc votre aide
Merci beaucoup !

 

[Rossoneri83]

Bonjour,

Sans fichier test c'est compliqué

Bonne journée

 

[job75]

Bonjour Idesevin, bienvenue sur XLD, Rossoneri83,

Bravo, le problème est très clairement posé, voyez le fichier joint et ce code :

Sub Ventiler()
Dim t, chemin$, dc As Object, df As Object, P As Range, tablo, i&, x$, classeur, feuille, nf%, nwb%, j%
t = Timer
chemin = ThisWorkbook.Path & "\Ventilation\" 'dossier et sous dossier à adapter
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'crée le sous-dossier s'il n'existe pas
Set dc = CreateObject("Scripting.Dictionary")
Set df = CreateObject("Scripting.Dictionary")
dc.CompareMode = vbTextCompare 'la casse est ignorée
df.CompareMode = vbTextCompare 'la casse est ignorée
Set P = [A1].CurrentRegion.Resize(, 10)
tablo = P 'matrice, plus rapide
'---listes des noms des classeurs et des feuilles sans doublon---
For i = 2 To UBound(tablo)
    x = Trim(tablo(i, 3))
    If x <> "" Then dc(x) = ""
    x = Trim(tablo(i, 4))
    If x <> "" Then df(x) = ""
Next i
'---création des classeurs et des feuilles---
classeur = dc.keys
feuille = df.keys
tri feuille, 0, UBound(feuille) 'classement des feuilles
nf = df.Count
nwb = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = nf
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 0 To UBound(classeur)
    With Workbooks.Add 'document vierge avec nf (4) feuilles
        For j = 1 To nf
            .Sheets(j).Name = feuille(j - 1)
            P(2, 12) = "=(C2=""" & classeur(i) & """)*(D2=""" & feuille(j - 1) & """)" 'critère
            P.AdvancedFilter xlFilterCopy, P(1, 12).Resize(2), .Sheets(j).Cells(1) 'filtre avancé
        Next j
        .SaveAs chemin & classeur(i), 51 'fichier .xlsx
        .Close
    End With
Next i
P(2, 12) = "" 'RAZ
Application.SheetsInNewWorkbook = nwb 'remise en l'état initial
MsgBox dc.Count & " classeurs créés en " & Format(Timer - t, "0.00 \sec")
End Sub

Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub

Les 80 classeurs créés sont regroupés dans le sous-dossier "Ventilation".

La macro s'exécute chez moi en [Edit] 16 secondes, ce n'est pas très rapide.

A+

 

[ldesevin]

Bonjour Idesevin, bienvenue sur XLD, Rossoneri83,

Bravo, le problème est très clairement posé, voyez le fichier joint et ce code :

Sub Ventiler()
Dim t, chemin$, dc As Object, df As Object, P As Range, tablo, i&, x$, classeur, feuille, nf%, nwb%, j%
t = Timer
chemin = ThisWorkbook.Path & "\Ventilation\" 'dossier et sous dossier à adapter
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'crée le sous-dossier s'il n'existe pas
Set dc = CreateObject("Scripting.Dictionary")
Set df = CreateObject("Scripting.Dictionary")
dc.CompareMode = vbTextCompare 'la casse est ignorée
df.CompareMode = vbTextCompare 'la casse est ignorée
Set P = [A1].CurrentRegion.Resize(, 10)
tablo = P 'matrice, plus rapide
'---listes des noms des classeurs et des feuilles sans doublon---
For i = 2 To UBound(tablo)
    x = Trim(tablo(i, 3))
    If x <> "" Then dc(x) = ""
    x = Trim(tablo(i, 4))
    If x <> "" Then df(x) = ""
Next i
'---création des classeurs et des feuilles---
classeur = dc.keys
feuille = df.keys
tri feuille, 0, UBound(feuille) 'classement des feuilles
nf = df.Count
nwb = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = nf
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 0 To UBound(classeur)
    With Workbooks.Add 'document vierge avec nf (4) feuilles
        For j = 1 To nf
            .Sheets(j).Name = feuille(j - 1)
            P(2, 12) = "=(C2=""" & classeur(i) & """)*(D2=""" & feuille(j - 1) & """)" 'critère
            P.AdvancedFilter xlFilterCopy, P(1, 12).Resize(2), .Sheets(j).Cells(1) 'filtre avancé
        Next j
        .SaveAs chemin & classeur(i), 51 'fichier .xlsx
        .Close
    End With
Next i
P(2, 12) = "" 'RAZ
Application.SheetsInNewWorkbook = nwb 'remise en l'état initial
MsgBox dc.Count & " classeurs créés en " & Format(Timer - t, "0.00 \sec")
End Sub

Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub

Les 80 classeurs créés sont regroupés dans le sous-dossier "Ventilation".

La macro s'exécute chez moi en [Edit] 16 secondes, ce n'est pas très rapide.

A+

Cher Job75,
Merci infiniment pour votre aide, et pardon d'avoir mis tant de temps à répondre. Cette macro fonctionne parfaitement, et m'a beaucoup aidé
A très vite !