Option Explicit
Private Function PréfixeFeuille(ByVal Z As String) As String
PréfixeFeuille = Left$(Z, PosPExcla(Z))
End Function
Private Function PosPExcla(ByVal Z As String) As Long
'Le nom de feuille peut contenir "!", et même "'!", ou commencer par "!", pourquoi pas, mais on ne peut
'se contenter de chercher tout simplement le dernier "!" car la suite de Z peut aussi contenir "#REF!" !
If Left$(Z, 1) = "'" Then PosPExcla = InStr(Replace(Mid$(Z, 2), "''", "??"), "'!") + 2 Else PosPExcla = InStr(Z, "!")
End Function
Sub Creer_Fichiers_Classes()
Dim X As String, 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
'-------------------------------------------------------------------------------------
'X = "Partie1Classe": On Error GoTo ErrClasse 'Portion du code à traiter si Erreur
'-------------------------------------------------------------------------------------
'---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
'Colonne A
Set P = P(i, 1).Resize(Application.CountIf(P.Columns(3), classe), P.Columns.Count)
'Nbre de lignes Ok
If Application.CountIf(P.Columns(5), "OK") <> P.Rows.Count Then Stop: MsgBox "Il faut que tous les onglets de " & classe & " soient validés par OK...": Exit Sub
'Fichier d'enregistrement du déroulement du programme
'Workbooks("Contrôles.xlsx").Sheets("Erreurs").Range("B1") = "Partie1Classe_OK"
'Workbooks("Contrôles.xlsx").Save
'---création des dossiers s'ils n'existent pas---
'-------------------------------------------------------------------------------------
'X = "Partie2Classe": On Error GoTo ErrClasse 'Portion du code à traiter si Erreur
'-------------------------------------------------------------------------------------
s = Split(P(1, 4), "\") 'Colonne D Masquée
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
'Fichier d'enregistrement du déroulement du programme
'Workbooks("Contrôles.xlsx").Sheets("Erreurs").Range("B2") = "Partie2Classe_OK"
'Workbooks("Contrôles.xlsx").Save
'-------------------------------------------------------------------------------------
'X = "Partie3Classe": On Error GoTo ErrClasse 'Portion du code à traiter si Erreur
'-------------------------------------------------------------------------------------
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
Set o = Nothing 'Déchargement de l'objet
For Each o In ActiveSheet.ListObjects 'tableaux structurés
o.Unlist 'convertit en plage
Next o
Set o = Nothing
For Each o In ActiveWorkbook.Connections 'Suppression des connections requêtes
o.Delete
Next o
Set o = Nothing
Range(w.UsedRange.Address) = w.UsedRange.Value 'supprime les formules
Cells.Hyperlinks.Delete 'supprime les liens hypertextes
Cells.Validation.Delete 'supprime les liens des listes de données
'Fichier d'enregistrement du déroulement du programme
'Workbooks("Contrôles.xlsx").Sheets("Erreurs").Range("B3") = "Partie3Classe_OK"
'Workbooks("Contrôles.xlsx").Save
'-------------------------------------------------------------------------------------
'X = "Partie4Classe": On Error GoTo ErrClasse 'Portion du code à traiter si Erreur
'-------------------------------------------------------------------------------------
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
For i = 1 To Sheets.Count
With Sheets(i)
.Select False 'sélection multiple
.PageSetup.Zoom = False
.PageSetup.FitToPagesWide = 1
End With
Next i
ActiveSheet.ExportAsFixedFormat xlTypePDF, chemin & c(1, 2) 'fichier PDF
ActiveWorkbook.Close False 'ferme le document
End If
Next c
'Fichier d'enregistrement du déroulement du programme
'Workbooks("Contrôles.xlsx").Sheets("Erreurs").Range("B4") = "Partie4Classe_OK"
'Workbooks("Contrôles.xlsx").Save
Exit Sub
'ErrClasse:
'Module 3 = Listing des Erreurs selon portion de code
'Call ErrListe(X)
End Sub