VBA Fonction saveas

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

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