XL 2016 VBA decomposer fichier en plusieurs fichiers avec critères et sans liaison

ZZ59264

XLDnaute Occasionnel
Bonjour à tous,

Je viens demandé de l'aide pour un projet assez conséquent, je joins donc un fichier à ma demande avec les explications,

Je suis prêt à écouter toute proposition (modifications,idées ...) pour aboutir au projet,

Merci d'avance pour votre aide,
 

Pièces jointes

  • TEST FORUM.xlsx
    24.7 KB · Affichages: 9
Solution
Bonjour ZZ59264,
Je voudrais qu'a la fin de la macro, la procédure lance une sauvegarde en PDF de chaque fichier Excel créer?,
Ça se passera ici, fichier (2) :
VB:
        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
A+

job75

XLDnaute Barbatruc
Bonjour ZZ59264,
Je voudrais qu'a la fin de la macro, la procédure lance une sauvegarde en PDF de chaque fichier Excel créer?,
Ça se passera ici, fichier (2) :
VB:
        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
A+
 

Pièces jointes

  • FORUM(2).xlsm
    286.5 KB · Affichages: 1

ZZ59264

XLDnaute Occasionnel
Bonjour Job75,

J'ai un problème sur le code et il se situe a ce niveau :

VB:
Range(w.UsedRange.Address) = w.UsedRange.Value 'supprime les formules

Il me met en erreur et le code affiché est " erreur d'execution 1004 : erreur définie par l'application ou par l'objet"

Merci pour votre aide,

Cordialement,t
 

ZZ59264

XLDnaute Occasionnel
Bonjour Job75,

J'ai un problème sur le code et il se situe a ce niveau :

VB:
Range(w.UsedRange.Address) = w.UsedRange.Value 'supprime les formules

Il me met en erreur et le code affiché est " erreur d'execution 1004 : erreur définie par l'application ou par l'objet"

Merci pour votre aide,

Cordialement,t
Je vous joins le code complet :

VB:
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
 

ZZ59264

XLDnaute Occasionnel
Je vous joins le code complet :

VB:
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
Je ne me souvenais plus mais j'avais déjà eu ce problème :

la solution est que dans mon fichier de travail ou il y a la macro, sur une des cellules je mets : '=40*2 et la il me met ce message d'erreur d’exécution,

Mais si je mets : '40*2 la je n'ai plus ce message d'erreur, cela ne me pose pas de problème mais pour qu'elle raison il accepte '40*2 et non '=40*2 ?

Merci d'avance,

Cordialement,
 

Discussions similaires

Réponses
4
Affichages
386

Statistiques des forums

Discussions
314 450
Messages
2 109 721
Membres
110 551
dernier inscrit
Khyolyanna