VBA - Récupérer une moyenne de plusieurs plages
Bonsoir à tous,
J'ai dû raté pas mal d'épisodes
Je n'avais pas pigé "le découpage"
Option Explicit
Sub Moyenne()
Dim a, b, w(), y, i As Long, j As Long, k As Long, x As Long, flag As Boolean
a = Sheets("Suivi").Range("a1").CurrentRegion.Columns("a:b").Value
With Sheets("Data")
b = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(, 4).Value
For i = 3 To UBound(a, 1)
For j = 3 + k To UBound(b, 1)
If CDec(b(j, 1)) <= CDec(a(i, 1)) Then
b(j, 4) = CDec(a(i, 1))
k = k + 1: flag = True
Else
flag = False: Exit For
End If
Next
Next
End With
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 3 To UBound(b, 1)
If Not .exists(b(i, 4)) Then
.Item(b(i, 4)) = VBA.Array(1, b(i, 3), b(i, 3))
Else
w = .Item(b(i, 4))
w(0) = w(0) + 1
w(1) = w(1) + b(i, 3)
w(2) = w(1) / w(0)
.Item(b(i, 4)) = w
End If
Next
x = .Count: y = .items
With Sheets("Suivi").[B3].Resize(x, 1)
.NumberFormat = "0.00"
'la moyenne
.Value = Application.Index(y, 0, 3)
'le nombre de valeurs
'.Value = Application.Index(y, 0, 1)
End With
End With
End Subklin89
Bonjour Klin89...Oui c'est possible mais c'est compréhensible vu votre position face au fichier. Je pense que vous n'êtes pas dans un bon jour car il manque la date en C1 et une valeur en C2 :/
Re Machin,
Pour t'éclairer, exécute cette macro quelque peu réajustée.
Regarde la colonne D de la feuille "Data"
Je m'appuie sur ces doublons pour ressortir tes moyennes.
Option Explicit
Sub Moyenne()
Dim a, b, w(), y, i As Long, j As Long, k As Long, x As Long, flag As Boolean
a = Sheets("Suivi").Range("a1").CurrentRegion.Columns("a:b").Value
With Sheets("Data")
b = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(, 4).Value
For i = 3 To UBound(a, 1)
For j = 3 + k To UBound(b, 1)
If CDec(b(j, 1)) <= CDec(a(i, 1)) Then
b(j, 4) = CDec(a(i, 1))
k = k + 1: flag = True
Else
flag = False: Exit For
End If
Next
Next
'A rajouter
With .Range("d1").Resize(UBound(b, 1), 1)
'pour visualiser la colonne D
'soit les doublons sur lesquels
'je m'appuie pour la suite du traitement
.NumberFormat = "hh:mm:ss"
.Value = Application.Index(b, 0, 4)
End With
End With
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 3 To UBound(b, 1)
If Not .exists(b(i, 4)) Then
.Item(b(i, 4)) = VBA.Array(1, b(i, 3), b(i, 3))
Else
w = .Item(b(i, 4))
w(0) = w(0) + 1
w(1) = w(1) + b(i, 3)
w(2) = w(1) / w(0)
.Item(b(i, 4)) = w
End If
Next
x = .Count: y = .items
With Sheets("Suivi").[B3].Resize(x, 1)
.NumberFormat = "0.00"
'la moyenne
.Value = Application.Index(y, 0, 3)
'le nombre de valeurs
'.Value = Application.Index(y, 0, 1)
End With
End With
End Subklin89
D'ailleurs y a un petit décalage d'une ligne ou deux car je préfère être basé sur le changement dans la colonne B que sur la colonne A. Mais cela sera transparent car mes valeurs ne changent pas de façon brutale, il y a une certaine inertie avant la redescente donc un décalage d'une ou deux secondes sera entièrement transparent dans une moyenne.
Re,
Je ne comprends plus rien, j'arrête
J'ai l'impression que tes tranches doivent se chevaucher
Je t'ai donné pas mal d'éléments, tu ne m'éclaires pas beaucoup à travers tes réponses.
Klin89
Bonsoir,
Adaptation sur la base de paliers définis dans 2 cellules :
Sub Moyennes2()
Dim tm(), a, b, m%, i%, j%, k%
With Worksheets("Suivi")
j = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
a = .Range("A27").Value: b = .Range("B27").Value
.Cells(1, j) = "Temps": .Cells(2, j) = "0:0"
.Cells(3, j) = "0:5": m = 3
Do
m = m + 1
.Cells(m, j) = .Cells(m - 1, j) + IIf(m Mod 2, b, a)
Loop While .Cells(m, j) < TimeSerial(0, 45, 0)
m = m - 2
ReDim tm(m, 3)
tm(0, 0) = 1: tm(0, 1) = j
For i = 1 To m
tm(i, 0) = .Cells(i + 2, j) * 86400 + 1
tm(i, 1) = tm(i, 0) - tm(i - 1, 0)
Next i
End With
With Worksheets("Data")
k = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 1 To m
For j = tm(i - 1, 0) + 1 To tm(i, 0)
tm(i, 2) = tm(i, 2) + .Cells(j, k).Value
Next j
tm(i, 3) = tm(i, 2) / tm(i, 1)
Next i
End With
With Worksheets("Suivi")
j = tm(0, 1) + 1
.Cells(1, j).Value = Worksheets("Data").Cells(1, k).Value
Range(.Cells(2, j), .Cells(m + 2, j)).NumberFormat = "0.00"
For i = 1 To m
.Cells(i + 2, j).Value = tm(i, 3)
Next i
End With
End SubJ'ai noté que tes couples de durées faisaient 5 minutes. Je n'en ai pas tenu compte pour simplifier, car après tout tu dois pouvoir y déroger. La macro sert par conséquent 2 colonnes sur Suivi : les temps et les moyennes... Et tu peux faire plusieurs extractions à la suite en faisant varier les paramètres sur la même base Data.
Cordialement
Re,
Le code réajusté, le résultat est-il similaire à celui obtenu par MFerrand
Option Explicit
Sub Moyenne()
Dim a, b, w(), y, i As Long, j As Long, k As Long, x As Long, flag As Boolean
With Sheets("Suivi").Range("a1").CurrentRegion
With .Columns("b").Offset(1).Resize(.Rows.Count - 1)
.ClearContents
End With
a = .Columns("a:b").Value
End With
With Sheets("Data")
.Columns("D").ClearContents
b = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(, 4).Value
For i = 2 To UBound(a, 1)
For j = 2 + k To UBound(b, 1)
If CDec(b(j, 1)) < CDec(a(i, 1)) Then
b(j, 4) = CDec(a(i, 1))
k = k + 1: flag = True
Else
flag = False: Exit For
End If
Next
Next
'A rajouter mais pas nécessaire
With .Range("d1").Resize(UBound(b, 1), 1)
'pour visualiser la colonne D
'soit les doublons sur lesquels
'je m'appuie pour la suite du traitement
.NumberFormat = "hh:mm:ss"
.Value = Application.Index(b, 0, 4)
End With
End With
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(b, 1)
If Not IsEmpty(b(i, 4)) Then
If Not .exists(b(i, 4)) Then
.Item(b(i, 4)) = VBA.Array(1, b(i, 3), b(i, 3))
Else
w = .Item(b(i, 4))
w(0) = w(0) + 1
w(1) = w(1) + b(i, 3)
w(2) = w(1) / w(0)
.Item(b(i, 4)) = w
End If
End If
Next
x = .Count: y = .items
With Sheets("Suivi").[B3].Resize(x, 1)
.NumberFormat = "0.00"
'la moyenne
.Value = Application.Index(y, 0, 3)
'le nombre de valeurs
'.Value = Application.Index(y, 0, 1)
End With
End With
End Subklin89
Bonjour Klin89 , MFerrand c'est gentil à vous de vous être proposé mais je vais arrêter là car plus on avance et plus les résultat sont differents.
Klin89 a écrit :Re, Le code réajusté, le résultat est-il similaire à celui obtenu par MFerrand
klin89
Oui sensiblement, si le découpage des plages ne suit pas la même proportion que MFerrand (à une ou deux lignes près) les différences de valeurs peuvent s'expliquer mais sur 3 macros, 3 résultats différents donc difficile pour moi de statuer.
Dans l'immédiat, je vais revenir sur une méthode de suivi plus manuelle et réfléchir à une suite.
Merci à vous 3.
Re Machin,
Sur le dernier fichier fourni par MFerrand, j'obtiens un résultat identique.
Les 2 macros renvoient le même résultat.
klin89
Bonjour Klin89..Cela veut donc dire qu'il y a une cause ailleurs que dans le calcul.J'ai ouvert un autre sujet pour traiter se problème par formule. C'est presque aboutis sauf un détail que je n'arrive pas à régler. J'espère ne pas être dans une impasse encore une fois.
Par contre dans celui là de fichier , vos résultats ne sont pas les mêmes avec les mêmes macro, d'où le fait que je n'insiste pas dans la voie vba pour ce petit souci
re Machin
Dans ton dernier fichier joint, exécute cette macro.
Restitution du résultat en feuil1.
Manuellement, obtiendrais-tu ce résultat
Option Explicit
Sub Moyenne()
Dim a, b, y, e, w()
Dim i As Long, j As Long, k As Long, x As Long, flag As Boolean
Application.ScreenUpdating = False
With Sheets("Suivi").Range("a1").CurrentRegion
With .Columns("b").Offset(1).Resize(.Rows.Count - 1)
.ClearContents
End With
a = .Columns("a:b").Value
End With
With Sheets("Data")
.Columns("D").ClearContents
b = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(, 4).Value
For i = 2 To UBound(a, 1)
For j = 2 + k To UBound(b, 1)
If CDec(b(j, 1)) < CDec(a(i, 1)) Then
b(j, 4) = CDec(a(i, 1))
k = k + 1: flag = True
Else
flag = False: Exit For
End If
Next
Next
'A rajouter
With .Range("d1").Resize(UBound(b, 1), 1)
'pour visualiser la colonne D
'soit les doublons sur lesquels
'je m'appuie pour la suite du traitement
.NumberFormat = "hh:mm:ss"
.Value = Application.Index(b, 0, 4)
End With
End With
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(b, 1)
If Not IsEmpty(b(i, 4)) Then
If Not .exists(b(i, 4)) Then
.Item(b(i, 4)) = VBA.Array(b(i, 4), 1, b(i, 3), Empty)
Else
w = .Item(b(i, 4))
w(1) = w(1) + 1
w(2) = w(2) + b(i, 3)
.Item(b(i, 4)) = w
End If
End If
Next
For Each e In .keys
w = .Item(e)
w(3) = w(2) / w(1)
.Item(e) = w
Next
x = .Count: y = .items
'Restitution en Feuil1
With Sheets("Feuil1").[A1]
.Parent.Cells.Clear
.Resize(1, 4) = Array("Temps", "Nombre", "Total", "Moyenne")
.Offset(1).Resize(x, 4).Value = Application.Index(y, 0, 0)
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 38
End With
.Columns.NumberFormat = Array("hh:mm:ss", "0", "#,##0", "0.00")
.Columns.ColumnWidth = Array(15, 12, 15, 16)
End With
End With
End With
Application.ScreenUpdating = True
End Subklin89
Bonjour Klin89, en terme de résultat c'est maintenant pertinent