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
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
Un petit exemple : http://cjoint.com/?BIowoY7bAgu
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
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
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 :
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 :
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
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
'---------------------------------------------
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 :
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
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