extraire feuilles vers un nouveau classeur grace à un usf

Le
magic-dd
bonjour

je possede un classeur avec x onglets

j'ai reussi a force de recherche à lister tous les onglets de mon classeu=
r dans un userform

mon but est de selectionner certains onglets listés dans ce userform et q=
u'a la validation cela les copie dans un nouveau classeur

voici mon code

Private Sub UserForm_Activate()
For Each sh In Worksheets
Next sh
End Sub

merci
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses Page 1 / 2
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
magic-dd
Le #24783742
Merci MichD

j'avais testé quelque chose comme toi sauf que si je selectionne 2 feuill es dans mon usf il n'en copie qu'une

ceci dit ton code est encore une fois beaucoup plus fluide que le mien.

quid?

est seulement possible?



Private Sub CommandButton1_Click()
Dim i As Integer
UserForm1.Hide
With ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) Then Sheets(.List(i)).copy
Next
End With
UserForm1.Show
End Sub

Private Sub UserForm_Initialize()
Dim s As Object
ListBox1.MultiSelect = fmMultiSelectExtended
For Each s In Sheets
ListBox1.AddItem s.Name
Next
End Sub
MichD
Le #24783872
Dans le formulaire,

Utilise ceci en lieu et place de l'autre :

'--------------------------------------
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
'Avec le listbox
With Me.ListBox1
'Pour chaque item du listbox
For a = 0 To .ListCount - 1
'si l'item est sélectionné
If .Selected(a) = True Then
'Extrait le nom de la feuille
NomFeuille = .List(a)
'copie cette feuille unique vers un nouveau classeur
ThisWorkbook.Worksheets(NomFeuille).Copy
End If
Next
End With
ThisWorkbook.Activate
Application.ScreenUpdating = True
MsgBox "Terminé."
End Sub
'--------------------------------------




"magic-dd" a écrit dans le message de groupe de discussion :


Merci MichD

j'avais testé quelque chose comme toi sauf que si je selectionne 2 feuilles
dans mon usf il n'en copie qu'une

ceci dit ton code est encore une fois beaucoup plus fluide que le mien.

quid?

est seulement possible?



Private Sub CommandButton1_Click()
Dim i As Integer
UserForm1.Hide
With ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) Then Sheets(.List(i)).copy
Next
End With
UserForm1.Show
End Sub

Private Sub UserForm_Initialize()
Dim s As Object
ListBox1.MultiSelect = fmMultiSelectExtended
For Each s In Sheets
ListBox1.AddItem s.Name
Next
End Sub
magic-dd
Le #24783892
on y est presque

jecherche aussi de mon coté mais tu m'as deja mis une longueur d'avance

donc le souci est qu'il créé autant de classeur que de feuille selectio nées dans la list box

grrr


Le vendredi 14 septembre 2012 21:51:51 UTC+2, magic-dd a écrit :
bonjour



je possede un classeur avec x onglets



j'ai reussi a force de recherche à lister tous les onglets de mon class eur dans un userform



mon but est de selectionner certains onglets listés dans ce userform et qu'a la validation cela les copie dans un nouveau classeur



voici mon code



Private Sub UserForm_Activate()

For Each sh In Worksheets

Next sh

End Sub



merci
Jacky
Le #24783982
Bonsoir,

A défaut de Denis (au diner peut-être)
;o))
Ce code de Denis modifié copie toutes les feuilles sélectionnées dans la listebox vers UN nouveau classeur
'------------------------
Private Sub CommandButton1_Click()
Dim DejaOuvert As Boolean
DejaOuvert = True
Application.ScreenUpdating = False
'Avec le listbox
With Me.ListBox1
'Pour chaque item du listbox
For a = 0 To .ListCount - 1
'si l'item est sélectionné
If .Selected(a) = True Then
'Extrait le nom de la feuille
NomFeuille = .List(a)
'copie cette feuille unique vers un nouveau classeur
If DejaOuvert = True Then
ThisWorkbook.Worksheets(NomFeuille).Copy
DejaOuvert = False
Else
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = NomFeuille
End If
End If
Next
End With
ThisWorkbook.Activate
Application.ScreenUpdating = True
MsgBox "Terminé."
End Sub
'----------------------------
--
Salutations
JJ


"magic-dd"
on y est presque

jecherche aussi de mon coté mais tu m'as deja mis une longueur d'avance

donc le souci est qu'il créé autant de classeur que de feuille selectionées dans la list box

grrr


Le vendredi 14 septembre 2012 21:51:51 UTC+2, magic-dd a écrit :
bonjour



je possede un classeur avec x onglets



j'ai reussi a force de recherche à lister tous les onglets de mon classeur dans un userform



mon but est de selectionner certains onglets listés dans ce userform et qu'a la validation cela les copie
dans un nouveau classeur



voici mon code



Private Sub UserForm_Activate()

For Each sh In Worksheets

Next sh

End Sub



merci
Jacky
Le #24784132
Oupss !!
J'ai oublié la copie des feuilles
'----------------
Private Sub CommandButton1_Click()
Dim DejaOuvert As Boolean, NomDuclasseur As String, ClasseurCible As String
DejaOuvert = True
NomDuclasseur = ThisWorkbook.Name
Application.ScreenUpdating = False
'Avec le listbox
With Me.ListBox1
'Pour chaque item du listbox
For a = 0 To .ListCount - 1
'si l'item est sélectionné
If .Selected(a) = True Then
'Extrait le nom de la feuille
NomFeuille = .List(a)
If DejaOuvert = True Then
ThisWorkbook.Worksheets(NomFeuille).Copy
ClasseurCible = ActiveWorkbook.Name
DejaOuvert = False
Else
Workbooks(NomDuclasseur).Worksheets(NomFeuille).Copy _
After:=Workbooks(ClasseurCible).Worksheets(Workbooks(ClasseurCible).Worksheets.Count)
End If
End If
Next
End With
ThisWorkbook.Activate
Application.ScreenUpdating = True
MsgBox "Terminé." & vbLf & "Nom du nouveau classeur: " & ClasseurCible
End Sub
'--------------

Sous l'oeil vigilant de Denis
;o)
--
Salutations
JJ
magic-dd
Le #24785072
Bonjour les champions excel

merci pour ce bout de code qui m'a donné du fil à retorde

tout fonctionne, seulement est il possible lors du transfert des feuilles d emander ou sauvegarder le nouveau classeur, faire la copie et le fermer afi n de revenir sur le classeur source.

merci
MichD
Le #24785172
Si tu veux copier tous les onglets dans le même nouveau fichier :

'---------------------------------------------
Private Sub CommandButton1_Click()
Dim A As Integer, T(), B As Integer

'Avec le listbox
With Me.ListBox1
If .ListIndex = 0 And .Selected(0) = False Then Exit Sub
Application.ScreenUpdating = False
'Pour chaque item du listbox
For A = 0 To .ListCount - 1
'si l'item est sélectionné
If .Selected(A) = True Then
'Extrait le nom de la feuille
ReDim Preserve T(B)
T(B) = .List(A)
B = B + 1
End If
Next
ThisWorkbook.Sheets(T).Copy
End With
ThisWorkbook.Activate
Application.ScreenUpdating = True
End Sub
'---------------------------------------------




"magic-dd" a écrit dans le message de groupe de discussion :


on y est presque

jecherche aussi de mon coté mais tu m'as deja mis une longueur d'avance

donc le souci est qu'il créé autant de classeur que de feuille selectionées
dans la list box

grrr


Le vendredi 14 septembre 2012 21:51:51 UTC+2, magic-dd a écrit :
bonjour



je possede un classeur avec x onglets



j'ai reussi a force de recherche à lister tous les onglets de mon classeur
dans un userform



mon but est de selectionner certains onglets listés dans ce userform et
qu'a la validation cela les copie dans un nouveau classeur



voici mon code



Private Sub UserForm_Activate()

For Each sh In Worksheets

Next sh

End Sub



merci
MichD
Le #24785222
Private Sub CommandButton1_Click()
Dim A As Integer, T(), B As Integer
Dim Chemin As String

Chemin = "D:Anglais" 'Le chemin du répertoire où
'tu veux enregistrer ton fichier.
'Avec le listbox
With Me.ListBox1
If .ListIndex = 0 And .Selected(0) = False Then Exit Sub
Application.ScreenUpdating = False
'Pour chaque item du listbox
For A = 0 To .ListCount - 1
'si l'item est sélectionné
If .Selected(A) = True Then
'Extrait le nom de la feuille
ReDim Preserve T(B)
T(B) = .List(A)
B = B + 1
End If
Next
ThisWorkbook.Sheets(T).Copy
Application.Dialogs(xlDialogSaveAs).Show Chemin & ActiveWorkbook.Name
If ActiveWorkbook.Saved Then
ActiveWorkbook.Close False
End If

End With
ThisWorkbook.Activate
Application.ScreenUpdating = True
End Sub
magic-dd
Le #24785262
Merci MichD

mais a forc de mofifier tous mes fichiers, plus rien ne marche

pourrais tu stp m'envoyer un cjoint pour que je reparte sur de bonnes bases
Publicité
Poster une réponse
Anonyme