XL 2013 Sélectionner des lignes selon critéres dans une colonne et créer 5 nouveaux classeurs

Luc MOUNY · 7 Juillet 2019

Bonsoir à tous,
C'est encore moi,

Actuellement, j'ai créé une feuille appelée BDD, et 5 feuilles nommées de 1 à 5. J'ai une macros qui copie le contenu de BDD dans chacune des autres feuilles, et une macros qui supprime les lignes ne comportant pas la variable indiquée dans une inputBox. Çà fonctionne, à condition de lancer les macros depuis chacune des feuilles de 1 à 5. Je n'arrive pas à enchainer les macros de la feuille 1 vers la 2 de la 2 vers la 3 etc. Tous les essais que j'ai pu faire sont infructueux et bloquent à la feuille 1, et malgré mes recherches, je n'ai rien trouvé d'approchant.

Depuis la feuille BDD, selon les chiffres de 1 à 5 en F, Je souhaite que toutes les lignes comportant le chiffre 1 soient copiées dans un nouveau classeur appelé Test 1 + date du jour et ainsi de suite pour les 4 autres chiffres, les lignes comportant 2 dans Test 2 + date du jour etc.

L'idéal serait d'extraire en une seule opération, chaque lignes comportant un des 5 chiffres et de les copier dans un nouveau classeur, comme indiqué ci-dessus

J'espère avoir été clair, Si ce n'est pas le cas, ci joint un fichier exemple.

Au pire, si vous pouviez m'aider à enchainer les macros de 1 à 2, de 2 à 3 etc, ce serait bien.
Merci d'avance ceux qui voudrons bien m'aiguiller vers la solution.
Très cordialement
Luc

mapomme · 7 Juillet 2019

Bonsoir @Luc MOUNY,

Un essai dans le fichier joint. Le code est dans module1. Si le fichier à sauvegarder existe déjà, vous pourrez soit écraser le fichier déjà existant, soit le sauvegarder sous un autre nom ou bien ne pas le sauvegarder.

VB:

Sub Ventiler()
Dim t, k&, i&, n&, j&, wbk As Workbook

Application.ScreenUpdating = False
With Worksheets("BDD")
  For k = 1 To 5
    t = .Range("a1:k" & .Cells(Rows.Count, "f").End(xlUp).Row)
    n = 1
    For i = 2 To UBound(t)
      If t(i, 6) = k Then
        n = n + 1
        For j = 1 To UBound(t, 2): t(n, j) = t(i, j): Next j
      End If
    Next i
    Set wbk = Workbooks.Add
    wbk.Worksheets(1).Range("a1").Resize(n, UBound(t, 2)) = t
    On Error Resume Next
    wbk.SaveAs Filename:=ThisWorkbook.Path & "\Test" & k & " " & Format(Date, "dd-mm-yyyy ") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    On Error GoTo 0
    wbk.Close
  Next k
End With
MsgBox "C'est fini !", vbInformation
End Sub

edit: préférer la version v1a.

Luc MOUNY · 7 Juillet 2019

mapomme à dit:
Bonsoir @Luc MOUNY,

Un essai dans le fichier joint. Le code est dans module1. Si le fichier à sauvegarder existe déjà, vous pourrez soit écraser le fichier déjà existant, soit le sauvegarder sous un autre nom ou bien ne pas le sauvegarder.

VB:

Sub Ventiler() Dim t, k&, i&, n&, j&, wbk As Workbook Application.ScreenUpdating = False With Worksheets("BDD") For k = 1 To 5 t = .Range("a1:k" & .Cells(Rows.Count, "f").End(xlUp).Row) n = 1 For i = 2 To UBound(t) If t(i, 6) = k Then n = n + 1 For j = 1 To UBound(t, 2): t(n, j) = t(i, j): Next j End If Next i Set wbk = Workbooks.Add wbk.Worksheets(1).Range("a1").Resize(n, UBound(t, 2)) = t On Error Resume Next wbk.SaveAs Filename:=ThisWorkbook.Path & "\Test" & k & " " & Format(Date, "dd-mm-yyyy ") & ".xlsx", FileFormat:=xlOpenXMLWorkbook On Error GoTo 0 wbk.Close Next k End With MsgBox "C'est fini !", vbInformation End Sub

edit: préférer la version v1a.

Luc MOUNY · 8 Juillet 2019

Bonsoir Mapomme,
Un grand merci pour la rapidité et la qualité de cette macro, qui parait fonctionner à merveille, J'ai fait un oubli dans mon poste, je n'ai pas précisé le dossier où enregistrer les 5 fichiers produits, ce n'est pas grave, je sauvegarde le fichier dans un dossier spécifique et les nouveaux classeurs s'y trouveront aussi. les test son concluants, je ferai des essais dès demain avec mon fichier beaucoup plus volumineux.

Excel-downloads est un forum génial tout comme ses contributeurs.

XL 2013 Sélectionner des lignes selon critéres dans une colonne et créer 5 nouveaux classeurs

Luc MOUNY

XLDnaute Junior

Pièces jointes

mapomme

XLDnaute Barbatruc

Pièces jointes

Luc MOUNY

XLDnaute Junior

Luc MOUNY

XLDnaute Junior

Discussions similaires