Bonjour à tous,
Suite au code fourni par Job75 que je salue au passage, pourriez vous regarder le code proposé car en l'utilisant les liens avec mes requêtes est toujours présent et il y a également un lien créer avec le fichier source :
	
	
	
	
	
		
Merci d'avance,
Cordialement,
	
		
			
		
		
	
				
			Suite au code fourni par Job75 que je salue au passage, pourriez vous regarder le code proposé car en l'utilisant les liens avec mes requêtes est toujours présent et il y a également un lien créer avec le fichier source :
		VB:
	
	
	Sub Creer_Fichiers_Classes()
Dim F As Worksheet, classe$, P As Range, i As Variant, s, chemin$, c As Range, w As Worksheet, o As Object, nom As Name, sup As Boolean
'---préparation---
Set F = Feuil1 'CodeName
classe = F.DrawingObjects(Application.Caller).Text 'les boutons doivent avoir des noms différents
Set P = F.ListObjects(1).Range 'tableau structuré
i = Application.Match(classe, P.Columns(3), 0) 'EQUIV
If IsError(i) Then MsgBox classe & " non trouvée !", 48: Exit Sub
Set P = P(i, 1).Resize(Application.CountIf(P.Columns(3), classe), P.Columns.Count)
If Application.CountIf(P.Columns(5), "OK") <> P.Rows.Count Then MsgBox "Il faut que tous les onglets de " & classe & " soient validés par OK...": Exit Sub
'---création des dossiers s'ils n'existent pas---
s = Split(P(1, 4), "\")
chemin = s(0) & "\" 'lecteur
For i = 1 To UBound(s)
    chemin = chemin & s(i) & "\"
    If Dir(chemin, vbDirectory) = "" Then MkDir chemin
Next i
'---création des fichiers---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier a déjà été créé
For Each c In P.Columns(1).Cells
    Set w = ThisWorkbook.Sheets(CStr(c))
    w.Visible = xlSheetVisible 'si la feuille est masquée
    Application.EnableEvents = False 'désactive les évènements
    If c(1, 2) <> c(0, 2) Then 'compare avec le nom de fichier au-dessus
        w.Copy 'crée un nouveau document
    Else
        w.Copy After:=ActiveSheet 'ajoute la feuille copiée
    End If
    Application.EnableEvents = True 'réactive les évènements
    For Each o In ActiveSheet.PivotTables 'TCD
        With o.TableRange2
            s = .Value 'mémorise les valeurs
            .ClearContents 'efface le TCD
            .Value = s 'restitue les valeurs
        End With
    Next o
    For Each o In ActiveSheet.ListObjects 'tableaux structurés
        o.Unlist 'convertit en plage
    Next o
    Range(w.UsedRange.Address) = w.UsedRange.Value 'supprime les formules
    If c(1, 2) <> c(2, 2) Then 'compare avec le nom de fichier au-dessous
    
On Error Resume Next
 For Each nom In ActiveWorkbook.Names
      If PréfixeFeuille(nom.Name) <> PréfixeFeuille(Mid$(nom.RefersTo, 2)) Then nom.Delete
 Next nom
 On Error GoTo 0
    
    
        Sheets(1).Select '1ère feuille
        ActiveWorkbook.SaveAs chemin & c(1, 2), 51 'enregistre avec l'extension .xlsx
        ActiveWorkbook.Close False 'ferme le document
    End If
Next c
End SubMerci d'avance,
Cordialement,
 
	 
 
		 
 
		 
 
		 
 
		 
 
		 
 
		 
 
		 
 
		 
 
		 
 
		 
 
		 
 
		 
 
		