Exporter plusieurs feuilles d'un classeur Excel

roudiroud Messages postés 36 Statut Membre -  
f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   -
Bonjour à tous,

Je voudrais savoir si il est possible d'exporter des feuilles préalablement choisient vers un autre classeur Excel ?

Sachant que je voudrais pouvoir donner le choix à l'utilisateur de choisir le nouvau nom du classeur. Avec une macro VBA.

Pensez-vous que c'est possible?

merci d'avance

3 réponses

  1.
    f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717
     
    erreur de personne .................
    1
    1. Stif
       
      Ah désolé il me semblait avoir répondu au sujet pourtant...
      Et concernant votre réponse précédente qui a disparue..... "No Comment"
      0
      1. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717 > Stif
         
        Re,

        Vous avez bien repondu, c'est moi qui me suis trompe precedemment.
        0
    2. Stif
       
      Ok, je ne comprenais pas pourquoi une telle réponse...

      Bonne journée à vous,
      0
      1. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717 > Stif
         
        Re,

        une autre facon de faire avec quelques tests et sans entrer le nombre de feuilles
        Tout dependra aussi du type de choix pour les feuilles 

        Option Explicit

Sub nouv_classeur()
    Dim nomclasseur1 As String, nomclasseur2 As String, feuillesàcopier As String, feuillesAcopier
    Dim numérodefeuilles As Integer, nombredefeuilles As Integer, feuilleencours As Integer
    Dim newBook As Workbook, NSh, Nom
    Dim I As Variant, x, xx
    
    nomclasseur1 = ActiveWorkbook.Name
    nomclasseur2 = InputBox("Nom du classeur", "Renseignez les noms du classeur à créer")
    If nomclasseur2 = "" Then MsgBox "Pas de nom de classeur!!!!!!!!!!!!!!!": Exit Sub
    feuillesàcopier = InputBox("Séparez les numéros par des virgules , ", "Renseignez les numéros de feuilles à copier")
    If feuillesàcopier = "" Then MsgBox "Pas de feuille(s) a copier!!!!!!!!!!!!!!!": Exit Sub

    feuillesAcopier = Split(feuillesàcopier, ",")
    'verif si numeros sont des entiers
    If Not verifNumero(feuillesAcopier) Then Exit Sub
    '
    If UBound(feuillesAcopier) = 0 Then
        nombredefeuilles = 1
    Else
        nombredefeuilles = UBound(feuillesAcopier) + 1
    End If
    If nombredefeuilles > Workbooks(nomclasseur1).Sheets.Count Then
        MsgBox "ATTENTION le classeur source ne contient que " & _
                        Workbooks(nomclasseur1).Sheets.Count & " feuilles / Impossible d'en exporter plus"
        Exit Sub
    End If

    Set newBook = Workbooks.Add
    With newBook
        .SaveAs Filename:="d:\_acsv1\" & nomclasseur2 + ".xls"
    End With
    nomclasseur2 = ActiveWorkbook.Name
    On Error Resume Next
    For NSh = 1 To nombredefeuilles
        Nom = Workbooks(nomclasseur1).Sheets(CInt(feuillesAcopier(NSh - 1))).Name
        Workbooks(nomclasseur1).Sheets(Nom).Copy After:=Workbooks(nomclasseur2).Sheets(Sheets.Count)
    Next NSh
    newBook.Close True
End Sub

Function verifNumero(feuillesAcopier) As Boolean
    Dim NF, Flag_Nok As Boolean, MSG, x
    On Error GoTo Table
    
    For NF = 0 To UBound(feuillesAcopier)
        x = CInt(feuillesAcopier(NF))
suite:
    Next NF
    If Not Flag_Nok Then
        verifNumero = True
    Else
        verifNumero = False
        MsgBox "Attention au separateur entre les numeros de feuille!!!!!" & vbNewLine & _
                        MSG, vbOKOnly, "ERREUR DE SEPARATEUR!!!!!"
    End If
    On Error GoTo 0
    Exit Function
Table:
    Flag_Nok = True
    MSG = MSG & feuillesAcopier(NF) & vbNewLine
    GoTo suite
End Function
        0
  2. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717
     
    Bonjour,

    Comment sont choisies les feuilles ???
    0
  3. Stif
     
    Bonjour,
    avec le peu de précisions de votre demande, je vous propose ces quelques lignes :

    Option Explicit

    Sub nouv_classeur()

    Dim nomclasseur1 As String, nomclasseur2 As String, feuillesàcopier As String
    Dim numérodefeuilles As Integer, nombredefeuilles As Integer, feuilleencours As Integer
    Dim newBook As Workbook
    Dim I As Variant

    nomclasseur1 = ActiveWorkbook.Name

    nomclasseur2 = InputBox("Nom du classeur", "Renseignez les noms du classeur à créer")
    nombredefeuilles = InputBox("Entrez un nombre", "Combien de feuilles voulez vous copier?")
    feuillesàcopier = InputBox("Séparez les numéros par des virgules , ", "Renseignez les numéros de feuilles à copier")
    feuillesàcopier = feuillesàcopier & ","

    Set newBook = Workbooks.Add
    With newBook
    .SaveAs Filename:=nomclasseur2 + ".xls"
    End With
    nomclasseur2 = ActiveWorkbook.Name
    If nombredefeuilles <= Workbooks(nomclasseur1).Sheets.Count Then
    If nombredefeuilles > 1 Then
    For I = 1 To nombredefeuilles
    If InStr(1, feuillesàcopier, ",") = 0 Then
    MsgBox "Attention une ou plusieurs feuille(s) non exportée(s) - Peut-être un oubli lors de la saisie..."
    Exit For
    End If
    feuilleencours = Mid(feuillesàcopier, 1, InStr(1, feuillesàcopier, ",") - 1)
    feuillesàcopier = Mid(feuillesàcopier, InStr(1, feuillesàcopier, ",") + 1, Len(feuillesàcopier))
    Workbooks(nomclasseur1).Sheets(feuilleencours).Copy After:=Workbooks(nomclasseur2).Sheets(Sheets.Count)
    Next I
    Else
    feuilleencours = Val(feuillesàcopier)
    Workbooks(nomclasseur1).Sheets(feuilleencours).Copy After:=Workbooks(nomclasseur2).Sheets(Sheets.Count)
    End If
    Else: MsgBox "ATTENTION le classeur source ne contient que " & Workbooks(nomclasseur1).Sheets.Count & " feuilles / Impossible d'en exporter plus"
    End If
    End Sub

    A votre disposition pour d'éventuels renseignements ou modifications.
    Cordialement,
    0