VBA Fonction saveas

Question

Bonjour à tous,

Je débute en macros Excel, et me heurte visiblement aux difficultés d'une fonction aussi simple que la fonction saveas...

Ce que je souhaite faire est simple, je souhaite détacher les onglets de mon classeur excel et les enregistrer tous dans un dossier, et que le nom du fichier soit le même que celui de l'onglet.

Ci-dessous le code que j'ai utilisé, le plus abouti auquel j'ai pu parvenir, mais insuffisant, il me copie effectivement les fichiers mais ne me les enregistre pas à l'endroit voulu, et même si je retire le chemin de l'inputbox, il me crée un fichier appelé false.xls, qui ne correspond pas au nom de mes onglets...

Sub detacher_onglets()

Dim nbreonglets As Integer
Dim i As Integer
Dim nome As String

Application.DisplayAlerts = False

nbreonglets = ActiveWorkbook.Sheets.Count
i = 1

chemin = InputBox("Où voulez-vous enregistrer le fichier ?", "Selection du dossier de destination")


For i = 1 To nbreonglets Step 1

Application.StatusBar = "Work in progress"

Workbooks("Flash.xls").Sheets(i).Activate
Workbooks("Flash.xls").Sheets(i).Select
nome = ActiveWorkbook.ActiveSheet.Name

Workbooks("Flash.xls").Sheets(i).Copy
Workbooks.Add

ActiveWorkbook.SaveAs Filename = chemin & nome & ".xls"

ActiveWorkbook.Sheets(2).Delete
ActiveWorkbook.Sheets(2).Delete
ActiveWorkbook.ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close

Next i

Application.StatusBar = "Terminé"
MsgBox ("Les onglets ont été détachés !")
Application.DisplayAlerts = True
ThisWorkbook.Close

End Sub

Merci d'avance de votre aide

Utilisateur anonyme · Answer

Bonjour,

voici un premier jet de votre solution, modifié !


Sub Detacher_Onglets()

    Dim nbreOnglets As Long, nbrI As Long, nbrNouvFeuil As Long
    Dim strNome As String, strChemin As String, strFeuille As String
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    strFeuille = ActiveWorkbook.ActiveSheet.Name
    nbrNouvFeuil = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1
    
    ' Cette propriété renvoie le nombre des objets de la collection.
    ' Type de données Long en lecture seule.
    ' expression.Count -> Donc nbrOnglet As Long
    nbreOnglets = ActiveWorkbook.Sheets.Count
    
    strChemin = InputBox("Où voulez-vous enregistrer le fichier ?", "Selection du dossier de destination")
    
    ' i = 1 -> Implicite ds le For
    For nbrI = 1 To nbreOnglets ' Step 1 -> Implicite
        Application.StatusBar = "Work in progress... " & ActiveWorkbook.ActiveSheet.Name
        'Workbooks("Flash.xls").Sheets(varI).Activate ' Implicite ds inst Select
        Workbooks("Ex_Enregistrer_Sous.xls").Sheets(nbrI).Select
        strNome = ActiveWorkbook.ActiveSheet.Name
        Workbooks("Ex_Enregistrer_Sous.xls").Sheets(nbrI).Copy
        'Workbooks.Add
        ActiveWorkbook.ActiveSheet.Paste
        ActiveWorkbook.SaveAs Filename:=strChemin & "\" & strNome & ".xls"
        ActiveWorkbook.Close
    Next nbrI
    
    Application.StatusBar = "Terminé"
    Application.SheetsInNewWorkbook = nbrNouvFeuil
    Sheets(strFeuille).Select
    Application.ScreenUpdating = True
    MsgBox ("Les onglets ont été détachés !")
    Application.DisplayAlerts = True
    ThisWorkbook.Close

End Sub
'


Quelques conseils !

Essayer toujours de "typé" une variable selon le type de l'objet que vous utilisé.
Dans l'aide de Excel, vous trouverez toujours le type de l'objet.

Dans la déclaration de vos variables, choissisé un code du genre :

cteBBBBBB (cte) pour Constante
strBBBBBB (str) pour String
nbrBBBBB (nbr) pour Long
etc...

ainsi, vous taper les 3 lettres de l'objet puis de façon simultanné [Ctrl]+[SpaceBar].

Je vais trouver une soluce plus robuste pour cet instruction :
// strChemin = InputBox("Où voulez-vous enregistrer le fichier ?", "Selection du dossier de destination") //
en utilisant les boites de dialogue, car au moment de la saisie, il est facile de se tromper !
Je recommande l'utilisation d'une fonction dédié qui retournera un [ Vrai/Faux ] pour la continuité
d'exécution sans bavure.

Bonne continuité
Lupin

Utilisateur anonyme · Answer

re:

Voilà, j'ai rendu le choix du dossier plus robuste !


Option Explicit
'

Sub Detacher_Onglets()

    Dim nbreOnglets As Long, nbrI As Long, nbrNouvFeuil As Long
    Dim strNome As String, strChemin As String, strFeuille As String
    Dim bolReponse As Boolean
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    strFeuille = ActiveWorkbook.ActiveSheet.Name
    nbrNouvFeuil = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1
    nbreOnglets = ActiveWorkbook.Sheets.Count
    bolReponse = SelectionneDossier(strChemin)
    
    If (bolReponse) Then
        For nbrI = 1 To nbreOnglets
            Application.StatusBar = "Work in progress... " & _
                                            ActiveWorkbook.ActiveSheet.Name
            Workbooks("Ex_Enregistrer_Sous.xls").Sheets(nbrI).Select
            strNome = ActiveWorkbook.ActiveSheet.Name
            Workbooks("Ex_Enregistrer_Sous.xls").Sheets(nbrI).Copy
            ActiveWorkbook.ActiveSheet.Paste
            ActiveWorkbook.SaveAs Filename:=strChemin & "\" & strNome & ".xls"
            ActiveWorkbook.Close
        Next nbrI
    End If
    
    Application.StatusBar = "Terminé"
    Application.SheetsInNewWorkbook = nbrNouvFeuil
    Sheets(strFeuille).Select
    Application.ScreenUpdating = True
    MsgBox ("Les onglets ont été détachés !")
    Application.DisplayAlerts = True
    'ThisWorkbook.Close

End Sub
'

Function SelectionneDossier(ByRef strCheminDestination As String) As Boolean
    
    Dim strCheminSource As String
    Dim strCheminCopie As String
    Dim bolDrapeau As Boolean
    
    On Error GoTo Err_Select_Dossier
    
    SelectionneDossier = False
    bolDrapeau = Application.DisplayAlerts
    Application.DisplayAlerts = False
    strCheminSource = ActiveWorkbook.FullName
    Application.Dialogs(xlDialogSaveAs).Show
    strCheminCopie = ActiveWorkbook.FullName
    strCheminDestination = ActiveWorkbook.Path
    ActiveWorkbook.SaveAs strCheminSource
    If (strCheminSource <> strCheminCopie) Then
        Kill strCheminCopie
    End If
    ChDir strCheminDestination
    
Exit_Select_Dossier:
    Application.DisplayAlerts = bolDrapeau
    SelectionneDossier = True
    Exit Function
    
Err_Select_Dossier:
    Application.DisplayAlerts = bolDrapeau
    SelectionneDossier = False
    
End Function
'

Lupin

VBA Fonction saveas

2 réponses

Discussions similaires

Newsletters