Sujet Précédent Sujet Suivant

Exporter plusieurs feuilles d'un classeur Excel

Fermé
roudiroud Messages postés 31 Date d'inscription mercredi 20 avril 2016 Statut Membre Dernière intervention 7 juin 2016 - Modifié par roudiroud le 20/05/2016 à 14:21
f894009 Messages postés 17200 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 11 septembre 2024 - 24 mai 2016 à 18:13
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
A voir également:

3 réponses

Réponse 1 / 3
f894009 Messages postés 17200 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 11 septembre 2024 1 708
Modifié par f894009 le 24/05/2016 à 16:43
erreur de personne .................
1
Stif
Modifié par Stif le 24/05/2016 à 17:01
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
f894009 Messages postés 17200 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 11 septembre 2024 1 708 > Stif
Modifié par f894009 le 24/05/2016 à 17:17
Re,

Vous avez bien repondu, c'est moi qui me suis trompe precedemment.
0
Stif
24 mai 2016 à 17:14
Ok, je ne comprenais pas pourquoi une telle réponse...

Bonne journée à vous,
0
f894009 Messages postés 17200 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 11 septembre 2024 1 708 > Stif
Modifié par f894009 le 24/05/2016 à 18:20
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
Réponse 2 / 3
f894009 Messages postés 17200 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 11 septembre 2024 1 708
22 mai 2016 à 09:23
Bonjour,

Comment sont choisies les feuilles ???
0
Réponse 3 / 3
Stif
24 mai 2016 à 16:26
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