Microsoft 365 Scinder un tableau en X fichiers contenant Y Onglets

job75 à dit:

Bonjour Idesevin, bienvenue sur XLD, Rossoneri83,

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

VB:

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+

Cliquez pour agrandir...