Copier des onglets vers un nouveau classeur répondant à une condition

[tactic6]

Bonjour tout le monde
j'essaie depuis une semaine de réaliser une macro pouvant de transférer des onglets sous une condition mais je n'arrive qu'a la moitié du processus
pourrais-je avoir un peu d'aide svp?
voici mon code

Sub maintenance()
Application.ScreenUpdating = True
Dim Compteur As Integer
Compteur = 0
Dim Feuille As Worksheet
Dim Nom_fichier As String
Const DossierSauvegarde As String = "H:\Contrat Maintenance\"
Dim Feuilles(1 To 2) '2 pour la copie de 2 feuilles
    Feuilles(1) = "Total des coûts"
    Feuilles(2) = "SYNTHESE"
    Sheets(Feuilles).Copy
Nom_fichier = Sheets("SYNTHESE").Range("D8") & " " & Sheets("SYNTHESE").Range("D11")
ActiveWorkbook.SaveAs DossierSauvegarde & Nom_fichier & " ", FileFormat:=-4143, CreateBackup:=False

[COLOR="Blue"]à partir d'ici ça ne marche plus
j'aimerai aussi recopier les onglets dont la cellule F6 a pour valeur 1 ou 2[/COLOR]

For Each Feuille In Worksheets
Range("F6").Select
If ActiveCell = ">0" Then '[COLOR="Blue"]test si présence de 1 ou 2[/COLOR]
Sheets(Feuilles).Copy
Nom_fichier = Sheets("SYNTHESE").Range("D8") & " " & Sheets("SYNTHESE").Range("D11")
ActiveWorkbook.SaveAs DossierSauvegarde & Nom_fichier & " ", FileFormat:=-4143, CreateBackup:=False
Application.ScreenUpdating = True
End If
Next Feuille
End Sub

Merci pour votre aide

EDIT
je crois comprendre que mon classeur de départ n'est plus pris en compte dans la deuxième partie de la macro
il faudrait que je trouve le moyen de de faire comprendre a ma macro que c'est lui qu'il faut prendre en compte et pas le résultat de la première partie

 

[tactic6]

Re : Copier des onglets vers un nouveau classeur répondant à une condition

Re tout le monde
voici un morceau de mon fichier
merci encore pour votre aide

Desolé trop gros alors very light

 

[tactic6]

Re : Copier des onglets vers un nouveau classeur répondant à une condition

Bonjour,
pas moyen d'automatiser la chose ?
j'ai essayé avec
Select Case Range("F6").Value
Case 0 To 2
mais ça ne donne rien
quelqu'un a une idée
merci

 

[tactic6]

Re : Copier des onglets vers un nouveau classeur répondant à une condition

Bonjour le forum
j'ai créé cette petite macro mais ça ne marche pas
quelqu'un pourrait me dire pourquoi ?
merci

Sub Copie_onglet()
Application.ScreenUpdating = True
Range("F6").Select
If ActiveCell = ">0" Then '[COLOR="SeaGreen"]Ici la condition est la présence d'un nombre >0[/COLOR]
Dim FU As Worksheet
For Each FU In ActiveWorkbook.Worksheets
FU.Copy
Next FU
End If
End Sub

j'essaierai après d'inclure les feuilles "total des coûts" et "SYNTHESE" et le tout dans un chemin bien précis

 

[mromain]

Re : Copier des onglets vers un nouveau classeur répondant à une condition

bonjour tactic6,

pour tester si ta cellule F6 est un nombre, il faut écrire
If IsNumeric(Range("F6").Value) Then

pour tester si ta cellule F6 est > à 0, il faut écrire
If Range("F6").Value > 0 Then

a+

 

[tactic6]

Re : Copier des onglets vers un nouveau classeur répondant à une condition

Bonjour et merci pour l'info
j'essaie d'adapter

 

[tactic6]

Re : Copier des onglets vers un nouveau classeur répondant à une condition

Bonjour et merci pour l'info
j'essaie d'adapter

edit

ça ne marche pas
pourquoi?

 

[tactic6]

Re : Copier des onglets vers un nouveau classeur répondant à une condition

Re encore
en utilisant le bout de code de Robert dans un autre fil j'obtiens enfin les feuilles répondant à la condition

Sub Macro1()
Dim sh As Worksheet
For Each sh In Sheets
    If sh.Range("F6").Value = "2" Then sh.Copy 
Next sh
End Sub

Maintenant est il possible de regrouper les éventuels onglets dans le même dossier d'y ajouter 2 feuilles bien définie et de renommer le tout?
merci

 

[tactic6]

Re : Copier des onglets vers un nouveau classeur répondant à une condition

Re à tous
ayant réussi à regrouper les feuilles à conditions dans un même classeur je mets ce code à disposition pour ceux à qui ça peut servir

Sub Mamacro2()
ReDim Feuilles(1 To 1)
Dim Compteur As Integer
Compteur = 0
Dim Feuille As Worksheet
For Each Feuille In Sheets
If Feuille.Range("F6").Value = "2" Then [COLOR="SeaGreen"]'Ici la condition est que le nombre soit égal à 2[/COLOR]
Compteur = Compteur + 1
ReDim Preserve Feuilles(1 To Compteur)
Feuilles(Compteur) = Feuille.Name
End If
Next Feuille
If Compteur > 0 Then Sheets(Feuilles).Copy
End Sub

je vais maintenant essayer d'y inclure 2 autres feuilles et de renommer le classeur final

@+

 

[tactic6]

Re : Copier des onglets vers un nouveau classeur répondant à une condition

Yo
là je bloque vraiment et j'ai un grand besoin d'aide pour finaliser
au code ci dessus j'aimerais donc y ajouter 2 feuilles nommées "SYNTHESE" et "Total des coûts"

je voudrais que le nom du classeur soit la cellule D8 et D11 de "SYNTHESE"
et que le chemin d'enregistrement soit "H:\Contrat Maintenance\"
j'ai réalisé ce code mais ça ne marche pas
mes compétences avec excel sont bien pauvres

Sub Mamacro2()

Application.ScreenUpdating = True
Const DossierSauvegarde As String = "H:\Contrat Maintenance\"
Dim Nom_fichier As String
ReDim Feuilles(1 To 1)
Dim Compteur As Integer
Compteur = 0
Dim Feuille As Worksheet
For Each Feuille In Sheets
If Feuille.Range("F6").Value > 0 Then 'Ici la condition est que le nombre soit égal à 2
Compteur = Compteur + 1
ReDim Preserve Feuilles(1 To Compteur)
Feuilles(Compteur) = Feuille.Name
End If
Next Feuille
If Compteur > 0 Then Sheets(Feuilles).Copy
Sheets("SYNTHESE").Copy
Sheets("Total des coûts").Copy
Nom_fichier = Sheets("SYNTHESE").Range("D8") & " " & Sheets("SYNTHESE").Range("D11")
ActiveWorkbook.SaveAs DossierSauvegarde & Nom_fichier & " ", FileFormat:=-4143, CreateBackup:=False
End Sub

help me please