Microsoft 365 Créer plusieurs onglets

themyse1

XLDnaute Nouveau
Bonjour,

J'en appel a votre aide pour m'aider à solutionner mon problème de macro.
j'aimerais à partir de l'onglet données, créer 12 onglet ( 1 par mois) et récupérer sur chaque onglet les éléments du mois.
j'ai un bouton en "N" qui est censé le faire mais il ne me récupère que le mois de janvier et que les données de la première ligne.
Pouvez vous me dire comment je fais pour qu'il me récupère chaque lignes de chaque mois dans l'onglet correspondant.
j'espère avoir été clair.

Merci infiniment de l'aide que vous m'apporterez
 

Pièces jointes

  • Classeur1.xls - Copie2.xlsm
    100.9 KB · Affichages: 5

Lolote83

XLDnaute Barbatruc
Bonjour,
Avec cette petite macro
Attention, j'ai renommé ton onglet Données à la place de donées
VB:
Sub Création_Onglets()
    Application.ScreenUpdating = False
    xListeMois = Array("janvier", "février", "mars", "avril", "mai", "juin", "juillet", "août", "septembre", "octobre", "novembre", "décembre")

    For F = 0 To 11
        With Sheets("Données")
            xMois = xListeMois(F)
            .Range("$A$1:$M$820").AutoFilter Field:=1, Criteria1:=xMois
            .Range("A1:M820").Copy
        End With
       
        xNbrOng = ThisWorkbook.Sheets.Count
        Sheets.Add After:=Sheets(xNbrOng)
        ActiveSheet.Name = xMois
       
        With Sheets(xMois)
            .Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
        End With
    Next F
    With Sheets("Données")
        .Select
        .Range("$A$1:$M$820").AutoFilter Field:=1
    End With
    MsgBox "Traitement terminé", vbInformation, "Création onglets"
    Application.ScreenUpdating = True
    ActiveWindow.TabRatio = 0.744
End Sub
@+ Lolote83
 

Cousinhub

XLDnaute Barbatruc
Bonjour,
Un essai avec ce code :
VB:
Sub Dispatch()
Dim Plg As Range, Cel As Range
Dim DerLig As Long
Dim Sh As Worksheet
Dim Le_Mois As Object
Dim It
Set Le_Mois = CreateObject("Scripting.Dictionary")
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With
For Each Sh In Sheets
    If Sh.Name <> "Donées" Then Sh.Delete 'Oups, "Donées"....
Next Sh
With Sheets("Donées")
    DerLig = .Cells(Rows.Count, "A").End(xlUp).Row
    Set Plg = .Range("A1:M" & DerLig)
    .Range("Z1").Value = .Range("A1").Value
    For Each Cel In .Range("A2:A" & DerLig)
        Le_Mois(Cel.Value) = Cel.Value
    Next Cel
    For Each It In Le_Mois.Items
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = It
        .Range("Z2").Value = It
        Plg.AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=.Range("Z1:Z2"), CopyToRange:=ActiveSheet.Range("A1"), Unique:=False
    Next It
    .Range("Z1:Z2").Clear
    .Select
End With
End Sub
Bonne journée

Edit, Oupss, pas vu Lolote (Meilleurs vœux)
 

Pièces jointes

  • Dispatch Themyse.xlsm
    65 KB · Affichages: 7

themyse1

XLDnaute Nouveau
Bonjour,
Avec cette petite macro
Attention, j'ai renommé ton onglet Données à la place de donées
VB:
Sub Création_Onglets()
    Application.ScreenUpdating = False
    xListeMois = Array("janvier", "février", "mars", "avril", "mai", "juin", "juillet", "août", "septembre", "octobre", "novembre", "décembre")

    For F = 0 To 11
        With Sheets("Données")
            xMois = xListeMois(F)
            .Range("$A$1:$M$820").AutoFilter Field:=1, Criteria1:=xMois
            .Range("A1:M820").Copy
        End With
      
        xNbrOng = ThisWorkbook.Sheets.Count
        Sheets.Add After:=Sheets(xNbrOng)
        ActiveSheet.Name = xMois
      
        With Sheets(xMois)
            .Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
        End With
    Next F
    With Sheets("Données")
        .Select
        .Range("$A$1:$M$820").AutoFilter Field:=1
    End With
    MsgBox "Traitement terminé", vbInformation, "Création onglets"
    Application.ScreenUpdating = True
    ActiveWindow.TabRatio = 0.744
End Sub
@+ Lolote83
Tu es Formidable Merci Merci Merci
 

themyse1

XLDnaute Nouveau
Bonjour,
Un essai avec ce code :
VB:
Sub Dispatch()
Dim Plg As Range, Cel As Range
Dim DerLig As Long
Dim Sh As Worksheet
Dim Le_Mois As Object
Dim It
Set Le_Mois = CreateObject("Scripting.Dictionary")
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With
For Each Sh In Sheets
    If Sh.Name <> "Donées" Then Sh.Delete 'Oups, "Donées"....
Next Sh
With Sheets("Donées")
    DerLig = .Cells(Rows.Count, "A").End(xlUp).Row
    Set Plg = .Range("A1:M" & DerLig)
    .Range("Z1").Value = .Range("A1").Value
    For Each Cel In .Range("A2:A" & DerLig)
        Le_Mois(Cel.Value) = Cel.Value
    Next Cel
    For Each It In Le_Mois.Items
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = It
        .Range("Z2").Value = It
        Plg.AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=.Range("Z1:Z2"), CopyToRange:=ActiveSheet.Range("A1"), Unique:=False
    Next It
    .Range("Z1:Z2").Clear
    .Select
End With
End Sub
Bonne journée

Edit, Oupss, pas vu Lolote (Meilleurs vœux)
Merci de ton aide, c'est top
 

Discussions similaires

Membres actuellement en ligne

Aucun membre en ligne actuellement.

Statistiques des forums

Discussions
313 259
Messages
2 096 618
Membres
106 688
dernier inscrit
Cherif99