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

Z

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
job75
Bonjour ZZ59264,
ZZ59264 à dit:
Je voudrais qu'a la fin de la macro, la procédure lance une sauvegarde en PDF de chaque fichier Excel créer?,
Cliquez pour agrandir...
Ç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+
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonjour ZZ59264,
ZZ59264 à dit:
Je voudrais qu'a la fin de la macro, la procédure lance une sauvegarde en PDF de chaque fichier Excel créer?,
Cliquez pour agrandir...
Ç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
Vote positif 0 Vote négatif
Solution
Z

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
 
Vote positif 0 Vote négatif
Z

ZZ59264

XLDnaute Occasionnel
ZZ59264 à dit:
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
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
Z

ZZ59264

XLDnaute Occasionnel
ZZ59264 à dit:
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
Cliquez pour agrandir...
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,
 
Vote positif 0 Vote négatif

Discussions similaires

A
  • Résolu(e)
Microsoft 365 Macro-commande et arrondi
Réponses
7
Affichages
259
Cousinhub
Cousinhub
Usine à gaz
  • Résolu(e)
XL 2021 Rechercher dans plusieurs fichiers
2
Réponses
18
Affichages
795
Usine à gaz
Usine à gaz
P
  • Résolu(e)
Microsoft 365 VBA et SommeProd
Réponses
4
Affichages
277
pierrof
P
Magnio
  • Question
XL 2016 Transfert de données d'un tableau en différenciant les libellés
Réponses
8
Affichages
213
Magnio
Magnio
Tomasisco21
  • Question
Microsoft 365 Fichier automatisé VBA - Template Budget project
Réponses
5
Affichages
542
Tomasisco21
Tomasisco21
L
  • Question
XL 2013 Liaisons Word / Excel : quelle solution retenir et comment la mettre en œuvre
2 3 4
Réponses
50
Affichages
3 K
LMOAL
L
S
  • Résolu(e)
Microsoft 365 Power Query Lancer un ensemble de requetes sur plusieurs fichiers excel
Réponses
2
Affichages
278
Sokko
S
M
  • Question
XL 2019 Comptabilité analytique avec VBA
Réponses
1
Affichages
630
Phil69970
Phil69970
Simbaa
  • Question
Microsoft 365 Création d'un fichier entier par rapport à des entrées via UserForm
Réponses
1
Affichages
364
job75
job75
Z
  • Résolu(e)
XL 2016 VBA Outlook avec pj et extrait tableau
Réponses
1
Affichages
373
ZZ59264
Z

Membres actuellement en ligne

24 membres et 427 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 238
Messages
2 086 492
Membres
103 234
dernier inscrit
matteo75654548