Moyenne de valeurs par date

Le 05/05/2022 à 09:18
Bonjour à tous,
J'essaie tant bien que mal de construire un fichier permettant de créer des moyennes classées par date.
Je m'explique. Plusieurs analyses sont faites par jour et chacune de ces analyses sortent une valeur (en %). J' aimerais donc pouvoir effectuer un tri permettant de regrouper les analyses par date et donc effectuer ensuite une moyenne de ces valeurs (toujours par date) dans des colonnes à coté. Par rapport au fichier, j'aimerais que seul la colonne date soit reportée sur une colonne préalablement décidée avec la macro sachant que la colonne des valeurs se trouve dans une colonne non contiguës à celle de la date. C'est-à-dire, avoir une colonne de titres "Date" avec les jours qui s'affiche (exemple : 26/03/2022 sur G2, puis 27/03/2022 sur G3 même si plusieurs analyses sont faites par jour) et une colonne "Moyenne MRI" effectuant la moyenne de toutes les valeurs (exemple : la moyenne des différentes valeurs des analyses effectuées le 26/03/2022 en H2 et la moyenne des valeurs du 27/03/2022 en H3 et ainsi de suite).
J'ai fournis un fichier test possédant la macro en question.
Voici également le code utilisé dans celle-ci en dessous.
Sub MoyenneDate()

    Dim DL%, T, Tout, M, i%, j%, k%, NbL%
    DL = Range("A5000").End(xlUp).Row

    T = Range("A2:E2" & DL)                                                           ' On transfert lse données dans le tableau T
    M = Range("D2" & DL)
    Titres = Range("A1,D1").Value                                                     ' On récupère les titres (pour mettre dans les feuilles qui n'existent pas)
    For i = 1 To UBound(T)                                                              ' Pour toutes les lignes
        ReDim Tout(UBound(T), 11)                                                       ' On redimensionne le tableau de sortie
        NbL = 0                                                                         ' Init du pointeur du tableau de sortie
        Libellé = T(i, 1)                                                               ' On récupère le libellé
        If Libellé <> "" Then                                                           ' Si non vide
            For j = 1 To UBound(T)                                                      ' On parcourt toutes les lignes
                If T(j, 1) = Libellé Then                                               ' Si c'est le bon libellé
                    For k = 0 To 3                                                      ' On transfert la ligne dans le tableau de sortie
                        Tout(NbL, k) = T(j, k + 1)
                    Next k
                    T(j, 1) = ""                                                        ' On efface le libellé du tableau d'entrée car déjà traité
                    NbL = NbL + 1                                                       ' On incrémente l'indice du tableau de sortie
                End If
            Next j
            On Error Resume Next
            Range("F1:J1") = Titres                                                   ' On initialise la ligne des titres
            Range("F2:J2") = T
            Range("K2") = Application.Average(M)
        End If
    Next i

End Sub
6test.xlsm (15.10 Ko)
Le 05/05/2022 à 09:29

Bonjour,

Je n'ai sans doute pas bien compris, mais un TCD ne suffirait pas ?

capture
6oloscob-2022-05-05-ex-p-test-13.xlsm (18.74 Ko)
Le 05/05/2022 à 10:02

Bonjour Eric,

Merci de votre réponse pour commencer. Effectivement j'avais totalement oublié le fait de pouvoir faire un TCD. Malheureusement, j'aimerais qu'il soit effectué par une macro pour plus de simplicité au sein de l'entreprise dans laquelle je travaille. J'ai donc créer ce tableau à la main en prenant soin d'activer l'enregistrement de macro. Cependant une fois l'enregistrement terminé, je supprime mon TCD afin de pouvoir activer la macro et vérifier son bon fonctionnement. Cela m'affiche constamment une erreur "Argument ou appel de procédure incorrect"... Est-ce normal ? Que dois-je modifier pour que cela puisse ce faire sans encombre ?

Sub CreerTableau()
'
' CreerTableau Macro
'
' Touche de raccourci du clavier: Ctrl+w
'
    Range("V23").Select
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Carte de contrôle MRI!R23C1:R500C4", Version:=6).CreatePivotTable _
        TableDestination:="Carte de contrôle MRI!R23C22", TableName:= _
        "Tableau croisé dynamique", DefaultVersion:=6
    Sheets("Carte de contrôle MRI").Select
    Cells(23, 22).Select
    With ActiveSheet.PivotTables("Tableau croisé dynamique")
        .ColumnGrand = True
        .HasAutoFormat = True
        .DisplayErrorString = False
        .DisplayNullString = True
        .EnableDrilldown = True
        .ErrorString = ""
        .MergeLabels = False
        .NullString = ""
        .PageFieldOrder = 2
        .PageFieldWrapCount = 0
        .PreserveFormatting = True
        .RowGrand = True
        .SaveData = True
        .PrintTitles = False
        .RepeatItemsOnEachPrintedPage = True
        .TotalsAnnotation = False
        .CompactRowIndent = 1
        .InGridDropZones = False
        .DisplayFieldCaptions = True
        .DisplayMemberPropertyTooltips = False
        .DisplayContextTooltips = True
        .ShowDrillIndicators = True
        .PrintDrillIndicators = False
        .AllowMultipleFilters = False
        .SortUsingCustomLists = True
        .FieldListSortAscending = False
        .ShowValuesRow = False
        .CalculatedMembersInFilters = False
        .RowAxisLayout xlCompactRow
    End With
    With ActiveSheet.PivotTables("Tableau croisé dynamique").PivotCache
        .RefreshOnFileOpen = False
        .MissingItemsLimit = xlMissingItemsDefault
    End With
    ActiveSheet.PivotTables("Tableau croisé dynamique").RepeatAllLabels _
        xlRepeatLabels
    ActiveWorkbook.ShowPivotTableFieldList = True
    With ActiveSheet.PivotTables("Tableau croisé dynamique").PivotFields("Date")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveSheet.PivotTables("Tableau croisé dynamique").AddDataField ActiveSheet. _
        PivotTables("Tableau croisé dynamique").PivotFields("Valeur du MRI (%)"), _
        "Somme de Valeur du MRI (%)", xlSum
    With ActiveSheet.PivotTables("Tableau croisé dynamique").PivotFields( _
        "Somme de Valeur du MRI (%)")
        .Caption = "Moyenne de Valeur du MRI (%)"
        .Function = xlAverage
    End With
    ActiveWorkbook.ShowPivotTableFieldList = False
    ActiveWorkbook.RefreshAll
    ActiveWindow.ScrollRow = 24
    ActiveWindow.ScrollColumn = 5
End Sub
Le 05/05/2022 à 10:30
Option Explicit

Sub TestCreationTcd()

    CreationTcd ActiveSheet

End Sub

Sub CreationTcd(ByVal Sh As Worksheet)

Dim I As Integer
Dim AireSource As Range
Dim Pvt As PivotTable

    With Sh

         If .PivotTables.Count > 0 Then
            For I = .PivotTables.Count To 1 Step -1
             .PivotTables(I).TableRange2.Delete
            Next I
         End If

         Set AireSource = .Range("A1").CurrentRegion
         ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=AireSource).CreatePivotTable TableDestination:=Sh.Range("G1"), TableName:="TCD"

         Set Pvt = .PivotTables("TCD")

         With Pvt
              With .PivotCache
                   .RefreshOnFileOpen = False
                   .MissingItemsLimit = xlMissingItemsDefault
              End With
              .RepeatAllLabels xlRepeatLabels
              With .PivotFields("Date")
                   .Orientation = xlRowField
                   .Position = 1
              End With
              .AddDataField .PivotFields("Valeur du MRI (%)"), "Moyenne de Valeur du MRI (%)", xlAverage
              With .PivotFields("Moyenne de Valeur du MRI (%)")
                   .NumberFormat = "0.00"
              End With
         End With

    End With

    Set AireSource = Nothing
    Set Pvt = Nothing

End Sub
Le 05/05/2022 à 10:40

Bonjour à tous,
Une autre proposition TCD en VBA.
A adapter.
Cdlt.

3olocsob.xlsm (19.24 Ko)
Option Explicit

Public Sub CreatePivotTable()
Dim wb As Workbook, ws As Worksheet
Dim lo As ListObject
Dim PTCache As PivotCache, PT As PivotTable

    Set wb = ActiveWorkbook
    Set ws = wb.Worksheets(1)
    Set lo = ws.Range("t_data").ListObject

    On Error Resume Next
    ws.PivotTables("PT_1").TableRange2.Clear
    On Error GoTo 0

    Set PTCache = wb.PivotCaches.Create(xlDatabase, lo.Range)
    Set PT = PTCache.CreatePivotTable(ws.Cells(1, 10), "PT_1")

    With PT
        .ManualUpdate = True
        .AddFields RowFields:="Date"
        With .PivotFields("Valeur du MRI (%)")
            .Orientation = xlDataField
            .Position = 1
            .Function = xlSum
            .NumberFormat = "#,##0_ ;[Red]-#,##0 ;"
            .Caption = "Somme " & "Valeur du MRI (%)"
        End With
        With .PivotFields("Valeur du MRI (%)")
            .Orientation = xlDataField
            .Position = 2
            .Function = xlAverage
            .NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 ;"
            .Caption = "Moyenne " & "Valeur du MRI (%)"
        End With
        .DisplayFieldCaptions = False
        .TableStyle2 = "PivotStyleLight1"
        .ManualUpdate = False
    End With

End Sub
Le 05/05/2022 à 10:53

Bonjour Eric, une erreur s'affiche à cette ligne quand j'essaie de le lancer sur ma véritable feuille. J'ai bien évidemment adapter le programme pour ma feuille

 ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=AireSource).CreatePivotTable TableDestination:=Sh.Range("G1"), TableName:="TCD"
Le 05/05/2022 à 10:56

Bonjour Jean-Eric,

Avec votre programme tout fonctionne plutôt bien mais en l'adaptant à mon fichier une erreur apparait sur cette ligne. Sauriez vous pourquoi ?

Set PTCache = wb.PivotCaches.Create(xlDatabase, lo.Range)
Option Explicit

Public Sub CreatePivotTable()
Dim wb As Workbook, ws As Worksheet
Dim lo As ListObject
Dim PTCache As PivotCache, PT As PivotTable

    Set wb = ActiveWorkbook
    Set ws = wb.Worksheets(1)
    Set lo = ws.Range("A24:D500").ListObject

    On Error Resume Next
    ws.PivotTables("PT_1").TableRange2.Clear
    On Error GoTo 0

    Set PTCache = wb.PivotCaches.Create(xlDatabase, lo.Range)
    Set PT = PTCache.CreatePivotTable(ws.Cells(1, 10), "PT_1")

    With PT
        .ManualUpdate = True
        .AddFields RowFields:="Date"
        With .PivotFields("Valeur du MRI (%)")
            .Orientation = xlDataField
            .Position = 1
            .Function = xlSum
            .NumberFormat = "#,##0_ ;[Red]-#,##0 ;"
            .Caption = "Somme " & "Valeur du MRI (%)"
        End With
        With .PivotFields("Valeur du MRI (%)")
            .Orientation = xlDataField
            .Position = 2
            .Function = xlAverage
            .NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 ;"
            .Caption = "Moyenne " & "Valeur du MRI (%)"
        End With
        .DisplayFieldCaptions = False
        .TableStyle2 = "PivotStyleLight1"
        .ManualUpdate = False
    End With

End Sub
Le 05/05/2022 à 11:05

Re,
Les données sont sous forme de tableau structuré (listobject)
A te relire..
Cdlt.

Le 05/05/2022 à 11:07

Que récupérez vous dans la fenêtre exécution Ctrl-G en insérant un Debug.Print ?

         Set AireSource = .Range("A1").CurrentRegion
         Debug.Print AireSource.Address
         ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=AireSource).CreatePivotTable TableDestination:=Sh.Range("G1"), TableName:="TCD"
Le 05/05/2022 à 13:26

Bonjour Jean-Eric, Cela fonctionne parfaitement !!

Merci beaucoup et Merci aussi à Eric Kergresse pour son aide

Rechercher des sujets similaires à "moyenne valeurs date"