Macro adaptée (pas testée)
Option Explicit
Public critere%
Sub dispatcher()
Dim Tbl As Variant, data As Variant, i%
Dim dico1 As Object, cle1 As Variant, result1 As Variant
Dim wb As Excel.Workbook
Dim MonRepertoire, Repertoire As FileDialog, racine As String
critere = 3 ' colonne C
racine = Split(ThisWorkbook.Name, ".")(0)
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
Repertoire.Show
If Repertoire.SelectedItems.Count = 0 Then Exit Sub
MonRepertoire = Repertoire.SelectedItems(1)
data = Sheets("data").Cells(Rows.Count, 1).End(xlUp).CurrentRegion
Set dico1 = CreateObject("Scripting.Dictionary")
For i = LBound(data) + 1 To UBound(data) ' hors en-tête
dico1(data(i, critere)) = ""
Next
Application.ScreenUpdating = False
For Each cle1 In dico1.Keys
result1 = filtreArray(data, critere, cle1)
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Model.xlsx")
wb.Sheets(4).Cells(2, 1).Resize(UBound(result1, 1), UBound(result1, 2)) = result1
wb.Sheets(1).PivotTables(1).ChangePivotCache wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="data!R1C1:R" & (UBound(result1, 1) + 1) & "C180", Version:=xlPivotTableVersion15)
wb.Sheets(1).PivotTables(1).PivotCache.Refresh
wb.Sheets(2).PivotTables(1).ChangePivotCache wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="data!R1C1:R" & (UBound(result1, 1) + 1) & "C180", Version:=xlPivotTableVersion15)
wb.Sheets(2).PivotTables(1).PivotCache.Refresh
wb.Sheets(3).PivotTables(1).ChangePivotCache wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="data!R1C1:R" & (UBound(result1, 1) + 1) & "C180", Version:=xlPivotTableVersion15)
wb.Sheets(3).PivotTables(1).PivotCache.Refresh
wb.SaveAs (MonRepertoire & "\" & cle1 & ".xlsx")
wb.Close
Set wb = Nothing
Next
Application.ScreenUpdating = True
MsgBox "Terminé, fichiers sauvegardés sous """ & MonRepertoire & "\" & """ !"
End Sub
Function filtreArray(Tbl, col, param)
Dim i%, j%, k%, n%
For i = 1 To UBound(Tbl)
If Tbl(i, col) = param Then n = n + 1
Next i
Dim temp: ReDim temp(1 To n, 1 To UBound(Tbl, 2))
j = 0
For i = 1 To UBound(Tbl)
If Tbl(i, col) = param Then
j = j + 1
For k = 1 To UBound(Tbl, 2)
temp(j, k) = Tbl(i, k)
Next k
End If
Next i
filtreArray = temp
End Function
et nouveau modèle