Créer nouvelle feuille selon liste et conditions

Le 19/05/2018 à 17:21

Bonjour à tous,

Je souhaiterai traiter des données de baseball et pour cela il me faudrait créer des feuilles sous conditions. Je vous explique tout ça.

La "Feuil1" contient les données. En colonne A il y a la date, en B le score des manches collées à l'affiche du match, en C le nombre total de point dans le match et de D à AG il y a une colonne par équipe (30 équipes).

Le but est de :

1. Filtrer les données pour chaque équipe. Prenons l'exemple fait à la main pour l'équipe KCA, on filtre les données de la colonne D pour avoir uniquement que les matchs de KCA.

2. On créer une feuille et copie les colonnes A à C dans cette nouvelle feuille qui a pour nom KCA.

3. On colle et déroule la formule "=SI(EST.PAIR(C1);"Pair";"")" en colonne D, la formule matricielle "=SI(D1="Pair";INDEX(FREQUENCE(SI(D$1:D$162="";LIGNE(D$1:D$162));SI(D$2:D$163="Pair";LIGNE(D$2:D$163)-1));NB.SI(D$1:D1;"Pair"));"")" en colonne E, la formule "=SI(EST.IMPAIR(C1);"Impair";"")" en colonne F, la formule matricielle "=SI(F1="Impair";INDEX(FREQUENCE(SI(F$1:F$100082="";LIGNE(F$1:F$100082));SI(F$2:F$100083="Impair";LIGNE(F$2:F$100083)-1));NB.SI(F$1:F1;"Impair"));"")" en colonne G. Ainsi que les autres formules (les max, le nb de match pair, le nombre de match impair)

4. On écrit le nom de l'équipe à la suite dans la colonne A de la feuille "Resume" ainsi que les autres données (nb match, max pair, impair, etc... voir fichier exemple joint)

Merci beaucoup pour votre aide !

N'hésitez pas si vous avez des qestions !

Quik

21mlb-team-by-team.xlsx (315.52 Ko)
Le 20/05/2018 à 09:13

Bonjour,

Voici un code à tester mais pour qu'il fonctionne au mieux, il est impératif que ta feuille "Feuil1" est des entêtes de colonnes car la copie du filtre embarque la première ligne d'office (qui est justement sensée être la ligne d'entêtes) :

Sub Test()

    Dim FeSource As Worksheet
    Dim FeCible As Worksheet
    Dim Plage As Range
    Dim TblLibele
    Dim TblFormule
    Dim Critere As String
    Dim I As Long

    TblLibele = Array("Max pair", "Max impair", "Nb pair", "Nb impair", "Nb Match")

    TblFormule = Array("=IF(MAX(E:E)>800,LARGE(E:E,2),MAX(E:E))+1", _
                       "=IF(MAX(G:G)>800,LARGE(G:G,2),MAX(G:G))+1", _
                       "=COUNTIF(D:D,""*Pair*"")", _
                       "=COUNTIF(F:F,""*Impair*"")", _
                       "=I4+I3")

    Critere = "KCA" 'adapter pour les différents critères

    Set FeSource = Worksheets("Feuil1")

    On Error Resume Next

    'si elle n'existe pas, la crée
    Set FeCible = Worksheets(Critere)
    If Err.Number <> 0 Then Set FeCible = Worksheets.Add(, Sheets(Sheets.Count))

    On Error GoTo 0

    FeCible.Name = Critere
    FeCible.Cells.Clear 'au cas ou elle existe et n'est pas vide de valeurs

    'défini la plage sur toute la feuille...
    Set Plage = DefPlage(FeSource, 1, 1)

    'et filtre sur la quatrième colonne (D)
    Plage.AutoFilter 4, "=" & Critere

    With FeSource

        .AutoFilter.Range.EntireRow.Copy FeCible.Cells(1, 1) 'copie du résultat sur la feuille cible

        Plage.AutoFilter 'suppression du filtrage

    End With

    'défini la plage après la colonne E pour suppression de toutes les valeurs inutiles
    Set Plage = DefPlage(FeCible, 1, 4)
    Plage.Clear

    'défini la plage sur ce qu'il reste (c'est juste pour avoir le nombre de lignes)
    Set Plage = DefPlage(FeCible, 2, 1)

    'entre les différentes formules. Attention, pour les matricielles, il faut être en référence R1C1
    With FeCible

        .Cells(2, 4).Formula = "=IF(ISEVEN(C2),""Pair"","""")"
        .Cells(2, 4).AutoFill .Range(.Cells(2, 4), .Cells(Plage.Rows.Count + 1, 4))

        .Cells(2, 6).Formula = "=IF(ISODD(C2),""Impair"","""")"
        .Cells(2, 6).AutoFill .Range(.Cells(2, 6), .Cells(Plage.Rows.Count + 1, 6))

        For I = 2 To Plage.Rows.Count + 1

            .Cells(I, 5).FormulaArray = "=IF(R[]C[-1]=""Pair"",INDEX(FREQUENCY(IF(R1C[-1]:R" & Plage.Rows.Count + 1 & "C[-1]="""",ROW(R1C[-1]:R" & Plage.Rows.Count + 1 & "C[-1])),IF(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1]=""Pair"",ROW(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1])-1)),COUNTIF(R2C[-1]:RC[-1],""Pair"")),"""")"
            .Cells(I, 7).FormulaArray = "=IF(RC[-1]=""Impair"",INDEX(FREQUENCY(IF(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1]="""",ROW(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1])),IF(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1]=""Impair"",ROW(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1])-1)),COUNTIF(R2C[-1]:RC[-1],""Impair"")),"""")"

        Next I

        For I = 0 To UBound(TblLibele)

            .Cells(I + 2, 8).Value = TblLibele(I)
            .Cells(I + 2, 9).Formula = TblFormule(I)

        Next I

    End With

End Sub

Function DefPlage(Fe As Worksheet, Optional L As Long = 1, Optional C As Long = 1) As Range

    On Error GoTo Fin

    With Fe

        Set DefPlage = .Range(.Cells(L, C), _
                       .Cells(.Cells.Find("*", .[A1], -4123, , _
                       1, 2).Row, .Cells.Find("*", .[A1], -4123, , _
                       2, 2).Column))

    End With

    Exit Function

Fin:

    Set DefPlage = Nothing

End Function
Le 20/05/2018 à 14:49

Bonjour Theze,

Merci pour votre réponse ! Cela fonctionne bien mais est-il pensable d'automatiser le processus et d'éviter de modifier à chaque fois le nom des équipes dans la macro ?

Merci

Quik

Le 20/05/2018 à 16:41

Re,

Voici le code modifié, je ne re poste pas la fonction :

Sub Test()

    Dim FeSource As Worksheet
    Dim FeCible As Worksheet
    Dim PlgEquipe As Range
    Dim Plage As Range
    Dim TblLibelle
    Dim TblFormule
    Dim NomFeuille As String
    Dim I As Long
    Dim J As Long

    TblLibelle = Array("Max pair", "Max impair", "Nb pair", "Nb impair", "Nb Match")

    TblFormule = Array("=IF(MAX(E:E)>800,LARGE(E:E,2),MAX(E:E))+1", _
                       "=IF(MAX(G:G)>800,LARGE(G:G,2),MAX(G:G))+1", _
                       "=COUNTIF(D:D,""*Pair*"")", _
                       "=COUNTIF(F:F,""*Impair*"")", _
                       "=I4+I3")

    'pour plus de rapidité
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    'supprime toutes les feuilles après la seconde
    If Worksheets.Count > 2 Then

        Application.DisplayAlerts = False

        For I = Worksheets.Count To 3 Step -1: Worksheets(I).Delete: Next I

        Application.DisplayAlerts = True

    End If

    Set FeSource = Worksheets("Feuil1")

    'défini la plage sur toute la feuille...
    Set PlgEquipe = DefPlage(FeSource, 1, 1)

    For I = 4 To PlgEquipe.Columns.Count

        Set FeCible = Worksheets.Add(, Sheets(Sheets.Count))

        'filtre sur les cellules non vides
        PlgEquipe.AutoFilter I, "<>"

        With FeSource

            .AutoFilter.Range.EntireRow.Copy FeCible.Cells(1, 1) 'copie du résultat sur la feuille cible
            PlgEquipe.AutoFilter 'suppression du filtrage

        End With

        NomFeuille = FeCible.Cells(2, I).Value

        'défini la plage après la colonne E pour suppression de toutes les valeurs inutiles
        Set Plage = DefPlage(FeCible, 1, 4)
        Plage.Clear

        'défini la plage sur ce qu'il reste (c'est juste pour avoir le nombre de lignes)
        Set Plage = DefPlage(FeCible, 2, 1)

        'entre les différentes formules. Attention, pour les matricielles, il faut être en référence R1C1
        With FeCible

            .Name = NomFeuille

            .Cells(2, 4).Formula = "=IF(ISEVEN(C2),""Pair"","""")"
            .Cells(2, 4).AutoFill .Range(.Cells(2, 4), .Cells(Plage.Rows.Count + 1, 4))

            .Cells(2, 6).Formula = "=IF(ISODD(C2),""Impair"","""")"
            .Cells(2, 6).AutoFill .Range(.Cells(2, 6), .Cells(Plage.Rows.Count + 1, 6))

            For J = 2 To Plage.Rows.Count + 1

                .Cells(J, 5).FormulaArray = "=IF(R[]C[-1]=""Pair"",INDEX(FREQUENCY(IF(R1C[-1]:R" & Plage.Rows.Count + 1 & "C[-1]="""",ROW(R1C[-1]:R" & Plage.Rows.Count + 1 & "C[-1])),IF(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1]=""Pair"",ROW(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1])-1)),COUNTIF(R2C[-1]:RC[-1],""Pair"")),"""")"
                .Cells(J, 7).FormulaArray = "=IF(RC[-1]=""Impair"",INDEX(FREQUENCY(IF(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1]="""",ROW(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1])),IF(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1]=""Impair"",ROW(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1])-1)),COUNTIF(R2C[-1]:RC[-1],""Impair"")),"""")"

            Next J

            For J = 0 To UBound(TblLibelle)

                .Cells(J + 2, 8).Value = TblLibelle(J)
                .Cells(J + 2, 9).Formula = TblFormule(J)

            Next J

        End With

    Next I

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub
Le 20/05/2018 à 18:49

Re Theze,

Merci beaucoup pour toute l'aide déjà apportée !

Vous avez vraiment la réponse à tout alors je me permet de demander d'autres options. Si vous avez marre dite le moi j'ouvrirai un nouveau sujet !

Il s'agirait d'ajouter la feuille "Resume" comme présentée dans le fichier joint ainsi que les formules allant de H7 à J47 dans chaque feuille d'équipe. L'exemple est fait pour la feuille de KCA.

Merci beaucoup !!

Quik

16team-by-team-avec-macro-theze.xlsm (756.78 Ko)
Le 21/05/2018 à 08:13

Bonjour,

Voici le code toujours sans la fonction DefPlage(). J'ai scindé le code en deux afin de séparer le paramétrage de la feuille "Resume" de la création des feuilles :

Sub Test()

    Dim FeSource As Worksheet
    Dim FeCible As Worksheet
    Dim PlgEquipe As Range
    Dim Plage As Range
    Dim TblLibelle
    Dim TblFormule
    Dim NomFeuille As String
    Dim I As Long
    Dim J As Long

    TblLibelle = Array("Max pair", "Max impair", "Nb pair", "Nb impair", "Nb Match")

    TblFormule = Array("=IF(MAX(E:E)>800,LARGE(E:E,2),MAX(E:E))+1", _
                       "=IF(MAX(G:G)>800,LARGE(G:G,2),MAX(G:G))+1", _
                       "=COUNTIF(D:D,""*Pair*"")", _
                       "=COUNTIF(F:F,""*Impair*"")", _
                       "=I4+I5")

    'pour plus de rapidité
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    'supprime toutes les feuilles après la seconde
    If Worksheets.Count > 2 Then

        Application.DisplayAlerts = False

        For I = Worksheets.Count To 3 Step -1: Worksheets(I).Delete: Next I

        Application.DisplayAlerts = True

    End If

    Set FeSource = Worksheets("Feuil1")

    'défini la plage sur toute la feuille...
    Set PlgEquipe = DefPlage(FeSource, 1, 1)

    For I = 4 To PlgEquipe.Columns.Count

        Set FeCible = Worksheets.Add(, Sheets(Sheets.Count))

        'filtre sur les cellules non vides
        PlgEquipe.AutoFilter I, "<>"

        With FeSource

            .AutoFilter.Range.EntireRow.Copy FeCible.Cells(1, 1) 'copie du résultat sur la feuille cible
            PlgEquipe.AutoFilter 'suppression du filtrage

        End With

        NomFeuille = FeCible.Cells(2, I).Value

        'défini la plage après la colonne E pour suppression de toutes les valeurs inutiles
        Set Plage = DefPlage(FeCible, 1, 4)
        Plage.Clear

        'défini la plage sur ce qu'il reste (c'est juste pour avoir le nombre de lignes)
        Set Plage = DefPlage(FeCible, 2, 1)

        'entre les différentes formules. Attention, pour les matricielles, il faut être en référence R1C1
        With FeCible

            .Name = NomFeuille

            .Cells(2, 4).Formula = "=IF(ISEVEN(C2),""Pair"","""")"
            .Cells(2, 4).AutoFill .Range(.Cells(2, 4), .Cells(Plage.Rows.Count + 1, 4))

            .Cells(2, 6).Formula = "=IF(ISODD(C2),""Impair"","""")"
            .Cells(2, 6).AutoFill .Range(.Cells(2, 6), .Cells(Plage.Rows.Count + 1, 6))

            For J = 2 To Plage.Rows.Count + 1

                .Cells(J, 5).FormulaArray = "=IF(R[]C[-1]=""Pair"",INDEX(FREQUENCY(IF(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1]="""",ROW(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1])),IF(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1]=""Pair"",ROW(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1])-1)),COUNTIF(R2C[-1]:RC[-1],""Pair"")),"""")"
                .Cells(J, 7).FormulaArray = "=IF(RC[-1]=""Impair"",INDEX(FREQUENCY(IF(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1]="""",ROW(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1])),IF(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1]=""Impair"",ROW(R2C[-1]:R" & Plage.Rows.Count + 1 & "C[-1])-1)),COUNTIF(R2C[-1]:RC[-1],""Impair"")),"""")"

            Next J

            For J = 0 To UBound(TblLibelle)

                .Cells(J + 2, 8).Value = TblLibelle(J)
                .Cells(J + 2, 9).Formula = TblFormule(J)

            Next J

            .Cells(7, 8).Formula = "=IF(COUNTIF(E:E,J7)>0,COUNTIF(E:E,J7),"""")"
            .Cells(7, 8).AutoFill .Range(.Cells(7, 8), .Cells(47, 8))

            .Cells(7, 9).Formula = "=IF(COUNTIF(G:G,J7)>0,COUNTIF(G:G,J7),"""")"
            .Cells(7, 9).AutoFill .Range(.Cells(7, 9), .Cells(47, 9))

            'incrémentation de 0 à 40
            .Cells(7, 10).Value = 0
            .Cells(8, 10).Value = 1
            .Range(.Cells(7, 10), .Cells(8, 10)).AutoFill .Range(.Cells(7, 10), .Cells(47, 10))

        End With

    Next I

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    'paramétrage de la feuille Resume
    Resumer Worksheets("Resume")

End Sub

Sub Resumer(FeCible As Worksheet)

    Dim Plage As Range
    Dim I As Long
    Dim J As Long

    With FeCible

        'défini la plage à partir de A2 afin de garder les valeurs en ligne 1...
        Set Plage = DefPlage(FeCible, 2, 1)

        'vide la plage
        Plage.Clear

        'formule MAX() sur la ligne 2
        For I = 3 To 47

            .Cells(2, I).Formula = "=MAX(" & Split(Cells(2, I).Address, "$")(1) & "3:" & Split(Cells(2, I).Address, "$")(1) & Worksheets.Count & ")"

        Next I

        'récup des différentes valeurs dans les différentes feuilles
        For I = 3 To Worksheets.Count

            .Cells(I, 1).Value = Worksheets(I).Name
            .Cells(I, 2).Value = Worksheets(I).Range("I6").Value
            .Cells(I, 3).Value = Worksheets(I).Range("I2").Value
            .Cells(I, 4).Value = Worksheets(I).Range("I3").Value
            .Cells(I, 5).Value = Worksheets(I).Range("I4").Value
            .Cells(I, 6).Value = Worksheets(I).Range("I5").Value

            .Range(.Cells(I, 7), .Cells(I, 47)).Value = Application.Transpose(Worksheets(I).Range(Worksheets(I).Cells(7, 8), Worksheets(I).Cells(47, 8)).Value)

        Next I

    End With

End Sub
Le 21/05/2018 à 21:51

Bonsoir,

Encore un grand merci pour votre code qui fonctionne une nouvelle fois parfaitement !

J'aurais un dernier souhait, serais-ce possible de reporter sur la feuille "Resume" les colonnes I7 à I47 de toutes les équipes (de la même manière qui est déjà utilisée pour les colonne H7 à H47) ?

Je vous ai fait un exemple à la main avec les équipes KCA et TBA. J'ai ajouté à les colonnes AW à CK (chiffre de 0 à 40) et les occurences correspondantes pour ces deux équipes 66,29,5,3,1,1 et 45,23,11,6,0,0,1.

Merci beaucoup !!!

Quik

20resume-et-feuil1.xlsm (796.19 Ko)
Le 22/05/2018 à 06:38

Bonjour,

Voici juste la procédure "Resumer" car elle seule est modifiée. Les valeurs de la première ligne doivent rester 0 à 40) :

Sub Resumer(FeCible As Worksheet)

    Dim Plage As Range
    Dim I As Long
    Dim J As Long

    With FeCible

        'défini la plage à partir de A2 afin de garder les valeurs en ligne 1...
        Set Plage = DefPlage(FeCible, 2, 1)

        'vide la plage
        Plage.Clear

        'formule MAX() sur la ligne 2
        For I = 3 To 47

            .Cells(2, I).Formula = "=MAX(" & Split(Cells(2, I).Address, "$")(1) & "3:" & Split(Cells(2, I).Address, "$")(1) & Worksheets.Count & ")"

        Next I

        'récup des différentes valeurs dans les différentes feuilles
        For I = 3 To Worksheets.Count

            .Cells(I, 1).Value = Worksheets(I).Name
            .Cells(I, 2).Value = Worksheets(I).Range("I6").Value
            .Cells(I, 3).Value = Worksheets(I).Range("I2").Value
            .Cells(I, 4).Value = Worksheets(I).Range("I3").Value
            .Cells(I, 5).Value = Worksheets(I).Range("I4").Value
            .Cells(I, 6).Value = Worksheets(I).Range("I5").Value

            .Range(.Cells(I, 7), .Cells(I, 47)).Value = Application.Transpose(Worksheets(I).Range(Worksheets(I).Cells(7, 8), Worksheets(I).Cells(47, 8)).Value)
            .Range(.Cells(I, 49), .Cells(I, 89)).Value = Application.Transpose(Worksheets(I).Range(Worksheets(I).Cells(7, 9), Worksheets(I).Cells(47, 9)).Value)

        Next I

    End With

End Sub
Le 22/05/2018 à 19:56

Parfait merci beaucoup je clot le sujet

A bientôt

Quik

Rechercher des sujets similaires à "creer nouvelle feuille liste conditions"