Macro pour enregistrer plusieurs onglets avec extension .xls

Question

Dans le fichier joint, il y a plusieurs onoglets je voudrais que chaque onglet soit enregistré avec une extension .xls j'ai fait une macro mais ca ressort en PDF. pouvez vous me corriger ? qui plus est, je voudrais une seule macro pour enregistrer tous les onglets en meme temps comment faire ? merci...

ThauThème · Answer

Essaie comme ça : Sub Macro1() Dim CA As String 'déclare la variable CA (Chemin d'Accès) Dim O As Worksheet 'déclare la variable O (Onglet) Dim CL As Workbook 'déclare la variable CL (CLasseur) Application.ScreenUpdating = False 'masque les rafraîchissements d'écran Application.DisplayAlerts = False 'interdit les messages d'Excel CA = "C:\Users\Documents\TEST\" 'définit le chemin d'accès CA For Each O In Worksheets 'boucle sur tous les onglet O du classeur O.Copy 'crée un nouveau classeur à partir de l'onglet O Set CL = ActiveWorkbook 'définit le classeur CL CL.SaveAs CA &amp; CL.Worksheets(1).Name, -4143 'enregistre sous le classeur CL CL.Close False 'ferme le classeur Cl sans enregistrer Next O 'prochaoin onglet de la boucle Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran Application.DisplayAlerts = True 'autorise les messages d'Excel MsgBox "Données traitées !" 'message End Sub...

ThauThème · Answer

Re,

Pour moi le tableau est mal structuré mais le code ci-desous devrait fonctionner :

Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim DF As Worksheet 'déclare la variable DF (Onglet du Fichier)
Dim I As Byte 'déclare la variable I (Incrément)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim RF As String 'déclare la variable RF (Référence du Fichier)
Dim A As String 'déclare la variable A (Année)
Dim M As String 'déclare la variable M (Mois)
Dim ML As String 'déclare la variable ML (Mois Long)
Dim NF As String 'déclare la variable NF (Nom du Fichier)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Application.DisplayAlerts = False 'interdit les messages d'Excel
Set CS = ThisWorkbook 'définit le classeur source CS
Set DF = CS.Worksheets("Dates fichiers") 'définit l'onglet DF
For I = 1 To 5 'boucle sur 5 onglets
    'CA = "C:\Users\Robert\Documents\Poubelle\Robert\TEST\"
    CA = "C:\Users\Documents\TEST\" 'définit le chemin d'accès initial
    RF = DF.Cells(2, I + 8).Value 'definit la référence du fichier RF
    A = Split(RF, ".")(0) 'récupère l'année A dans la référence du fichier RF
    On Error Resume Next 'gestion des errurs (en cas d'erreur passe à la ligne suivante)
    ChDir (CA & A) 'change le dossier courant (génère une erreur si le dossier n'existe pas)
    If Err <> 0 Then MkDir CA & A 'si une erreur a été générée, crée un sous-dossier de CA avec l'année A
    On Error GoTo 0 'annule la gestion des erreurs
    CA = CA & A & "\" 'redéfinit le chemin d'accès CA (avec le sous dossier de l'année)
    M = Split(RF, ".")(1) 'récupère le mois M dans la référence du fichier RF
    'définit le mois long ML
    ML = M & " - " & Choose(M, "JANVIER", "FÉVRIER", "MARS", "AVRIL", "MAI", "JUIN", "JUILLET", "AOÛT", "SEPTEMBRE", "OCTOBRE", "NOVEMBRE", "DÉCEMBRE")
    On Error Resume Next 'gestion des errurs (en cas d'erreur passe à la ligne suivante)
    ChDir (CA & ML) 'change le dossier courant (génère une erreur si le dossier n'existe pas)
    If Err <> 0 Then MkDir CA & ML 'si une erreur a été générée, crée un sous-dossier de CA avec le mois ML
    On Error GoTo 0 'annule la gestion des erreurs
    CA = CA & ML & "\" 'redéfinit le chemin d'accès CA (avec le sous dossier du mois)
    NF = DF.Cells(1, I + 8).Value 'recupère le nom du fichier NF dans la cellule ligne colonne I+8
    CS.Worksheets(I).Copy 'crée un nouveau classeur à partir de l'onglet numéro I
    Set CD = ActiveWorkbook 'définit le classeur destination CD
    CD.SaveAs CA & NF, -4143  'enregistre sous le classeur CD
    CD.Close False 'ferme le classeur destination CD sans enregistrer
Next I 'prochain onglet de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
Application.DisplayAlerts = True 'autorise les messages d'Excel
MsgBox "Données traitées !" 'message
End Sub