Regrouper des feuilles d'un classeur par critère

Bonsoir

existe il une facon de pouvoir regrouper certaines feuilles d'un meme classeur nommé C1 ( vers un autre classeur ) selon un critère simple qui serait par exemple : "si toutes les cellules H7 de toutes mes feuilles de mon classeur C1 sont renseignées alors toutes ces feuilles seraient automatiquement renvoyées en copie dans un nouveau classeur que je pourrai appeler "extraction de feuilles " ?

cela est il possible ?

Merci pour vos avis

Salut Rocket,

Oui c'est possible.

Voici une tentative de démonstration. Tu places les deux fichiers joins dans le même dossier puis tu ouvres le fichier "C1".

Lorsque tu cliques sur le bouton, ça devrait ouvrir le fichier "Extraction de feuilles" et y enregistrer une copie des feuilles comportant une cellule H7 non vide du fichier "C1". Ca fonctionne en tout cas bien che moi

Lorsque cela est fait, que désires-tu ? Refermer le fichier "Extraction de feuilles" après l'avoir enregistré ? Sélectionner une autre feuille que la dernière feuille du fichier "C1" (par exemple revenir sur la première feuille) ?

A te relire.

.. je ne peux rester que sans voix devant tes prouesses Yvouille ! ....excel se déshabille pour certains mais pas pour d'autres :

il me vient une nouvelle question relative à ce post ,

Est qu'il est possible d'inclure dans la macro du bouton d'extraction des feuilles voulues , une ligne de commande permettant de créer le classeur "extraction de feuilles" avant que la copie des feuilles soit effectuée sur ce dernier et que lorsque la copie est effectuée de nettoyer toutes les cellules H7 de toutes les pages du classeur C1

voila ce que j'ai essayé de faire à partir de ton code , si tu peux m'apporter une correction :

Option Explicit
Sub a()
Dim Chemin As String, j As Integer
Application.ScreenUpdating = False

Chemin = ActiveWorkbook.Path
WorkBooks.Add
ActiveWorkbook.SaveAs "C:\Chemin &\Extractions de feuilles.xls"  '  je crée le classeur  extraction 
Windows("C1.xls").Activate

 For j = 1 To Sheets.Count
    Sheets(j).Activate
    If Range("H7") <> "" Then

        Sheets(j).Copy Before:=Workbooks("Extraction de feuille.xls").Sheets(1)
        Windows("C1.xls").Activate
    End If
For j = 1 To Sheets.Count
    Sheets(j).Activate
Range("H7").Clear   '  je nettoie toutes les cellules h7 du classeur C1
Next

End Sub

merci beaucoup

je l'ai refait en plus propre car ca ne marchait pas

ca donne :

Option Explicit
Sub a()
Dim Chemin As String, j As Integer
Application.ScreenUpdating = False

Chemin = ActiveWorkbook.Path
Workbooks.Add
ActiveWorkbook.SaveAs "C:\Users\ROCKET\Desktop\Nouveau dossier (8)\Extraction de feuille.xls"

Workbooks.Open Filename:=Chemin & "\Extraction de feuille.xls"
Windows("C1.xls").Activate

For j = 1 To Sheets.Count
    Sheets(j).Activate
    If Range("H7") <> "" Then

        Sheets(j).Copy Before:=Workbooks("Extraction de feuille.xls").Sheets(1)
        Windows("C1.xls").Activate
    End If
Next
For j = 1 To Sheets.Count
    Sheets(j).Activate
    Range("H7").Clear
    Next

End Sub

le seul petit soucis que j'ai c'est que j'obtiens sur le classeur "extraction de feuille " des feuilles nommées Feuil1(2) , Feuil2(2)

pourtant je n'ai pas deux fois les memes feuilles , sans comprendre le pourquoi

en plus fournis :

Option Explicit
Sub a()
Dim Chemin As String, j As Integer
Application.ScreenUpdating = False

Chemin = ActiveWorkbook.Path
Workbooks.Add
ActiveWorkbook.SaveAs "C:\Users\AHMED\Desktop\Nouveau dossier (8)\Extraction de feuille.xls"

Workbooks.Open Filename:=Chemin & "\Extraction de feuille.xls"
Windows("C1.xls").Activate

For j = 1 To Sheets.Count
    Sheets(j).Activate
    If Range("H7") <> "" Then

        Sheets(j).Copy Before:=Workbooks("Extraction de feuille.xls").Sheets(1)
        Windows("C1.xls").Activate
    End If
Next
For j = 1 To Sheets.Count
    Sheets(j).Activate
    Range("H7").Clear
    Next
Windows("Extraction de feuille.xls").Close
With Windows("C1.xls")
Sheets("Feuil1").Select
End With
End Sub

je commence à sentir le vba en moi

Re,

rocket4 a écrit :

le seul petit soucis que j'ai c'est ......

Concernant le nom des feuilles, cela vient du fait que la copie de la feuille est faite dans le fichier de base, avant son transfert. Si ça te dérange, le plus simple serait de renommer les feuilles à ta convenance, après les avoir dupliquées ou à la fin du code. A toi de nous indiquer comment les renommer si tu ne sais pas le faire.

A te relire.

Voici encore une simplification possible - mais surement pas absolue - du dernier code que tu as fourni :

Sub a()
''''Dim Chemin As String, INUTILISE SUITE A TA MODIFICATION
Dim j As Integer
Application.ScreenUpdating = False

'''''Chemin = ActiveWorkbook.Path INUTILISE SUITE A TA MODIFICATION
Workbooks.Add
ActiveWorkbook.SaveAs "C:\Users\AHMED\Desktop\Nouveau dossier (8)\Extraction de feuille.xls"

'''''Workbooks.Open Filename:=Chemin & "\Extraction de feuille.xls" INUTILE SUITE A TA MODIFICATION CAR DEJA OUVERT
Windows("C1.xls").Activate

For j = 1 To Sheets.Count
    Sheets(j).Activate
    If Range("H7") <> "" Then
        Sheets(j).Copy Before:=Workbooks("Extraction de feuille.xls").Sheets(1)
        Windows("C1.xls").Activate
        Range("H7").Clear '''' INSTRUCTION DEPLACEE
    End If
Next

'''''For j = 1 To Sheets.Count
'''''    Sheets(j).Activate
'''''    Range("H7").Clear DEPLACE CI-DESSUS
'''''Next

Windows("Extraction de feuille.xls").Close
'''''With Windows("C1.xls") CE FICHIER EST SELECTIONNE
Sheets("Feuil1").Select
'''''End With
End Sub

Attention, dans tes codes tu nous fournis des informations personnelles

Cordialement

merci , pas grave ! ....j'entend pas etre hacké

je ne vois pas comment faire pour renommer les onglets du classeur extraction en fonction du contenu de la cellule H7 de C1

par contre

j'ai pensé à ca :

Windows("C1.xls").Activate
For j = 1 To Sheets.Count
    Sheets(j).Activate
    Range("H7").copy  to
    windows("Extraction de feuille").Select
    référence_Nom = Range("H7")

sans grosse certitude !

Essaie plutôt

Sub a()
Dim j As Integer
Application.ScreenUpdating = False

Workbooks.Add
ActiveWorkbook.SaveAs "C:\Users\AHMED\Desktop\Nouveau dossier (8)\Extraction de feuille.xls"
Windows("C1.xls").Activate

For j = 1 To Sheets.Count
    Sheets(j).Activate
    If Range("H7") <> "" Then
        Sheets(j).Copy Before:=Workbooks("Extraction de feuille.xls").Sheets(1)
        Sheets(j).Name = Range("H7")
        Windows("C1.xls").Activate
        Range("H7").Clear
    End If
Next

Windows("Extraction de feuille.xls").Close
Sheets("Feuil1").Select
End Sub

Cordialement

Merci à toi yvouille , ca marche tres bien mis par que j'ai toujours le probleme des feuilles nommées : feuil2(2)

feuil3(2) ! j'ai pas réussi à résoudre ce probleme ou à m'en defaire apres lecture de ta réponse concernant ce fait . certaines sont bien nommées et portent le nom des cellules h7 des pages à transferer .

Désolé, j'ai fait des essais trop sommaires et je ne me suis pas rendu compte d'un problème (commentaires directement dans le code).

Sub a()
Dim j As Integer
Application.ScreenUpdating = False

Workbooks.Add
ActiveWorkbook.SaveAs "C:\Users\AHMED\Desktop\Nouveau dossier (8)\Extraction de feuille.xls"
Windows("C1.xls").Activate

For j = 1 To Sheets.Count
    Sheets(j).Activate
    If Range("H7") <> "" Then
        Sheets(j).Copy Before:=Workbooks("Extraction de feuille.xls").Sheets(1)
        ActiveSheet.Name = Range("H7") 'Modifié afin que ça ne renomme pas une autre feuille que celle désirée
         Windows("C1.xls").Activate
        Range("H7").ClearContents 'Modifié afin de ne pas effacer la mise en forme 
    End If
Next

Windows("Extraction de feuille.xls").Close
Sheets("Feuil1").Select
End Sub

Cordialement

Bonjour

Désolé Yvouille d'intervenir dans un post dans lequel tu as trouvé une bonne solution

Dans mon idée je ne voulais que les feuilles (sans celles obtenues à la création du fichier)

Et surtout ne créer un fichier que si nécessaire

Sub a()
Dim Ws As Worksheet
Dim WbkD As Workbook

  Application.ScreenUpdating = False
  With ThisWorkbook
    For Each Ws In .Sheets
      If Ws.Range("H7") <> "" Then
        If WbkD Is Nothing Then
          Ws.Copy
          Set WbkD = ActiveWorkbook
        Else
          Ws.Copy after:=WbkD.Sheets(WbkD.Sheets.Count)
        End If
        ActiveSheet.DrawingObjects.Delete
        ActiveSheet.Name = Ws.Range("H7")
        Ws.Range("H7").ClearContents
      End If
    Next Ws
  End With

  If Not WbkD Is Nothing Then
    With WbkD
      .SaveAs "C:\Users\AHMED\Desktop\Nouveau dossier (8)\Extraction de feuille.xls"
      ' Ma sauvegarde : Evite d'avoir le même nom
'      .SaveAs ThisWorkbook.Path & "\Extraction de feuille le " & Format(Now, "yyyy mm dd hhmmss") & ".xls"
      .Close
    End With
  Else
    MsgBox "Pas de feuilles à copier"
  End If
End Sub

Merci Yvouille je t'en suis infiniment reconnaissant et merci aussi à Banzai pour ce supplément de réponse , j’espère de mon coté progresser le plus tot possible en vba et etre capable d'en faire autant