1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49
| Sub Somme_pmo()
Dim interval
Dim S As Worksheet
Dim R As Range
Dim var
Dim i&
Dim T()
Dim cpt&
Dim x#
interval = Sheets("Procedure").[i16]
If Not IsNumeric(interval) Then
MsgBox "La valeur de I16 de la feuille Procedure n'es pas numérique"
Exit Sub
End If
Set S = Sheets("Calculs")
S.Copy after:=S
Set S = ActiveSheet
Set R = S.UsedRange
R.Copy
R.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
R.Sort Key1:=S.[D2], Order1:=xlAscending, Header:=xlYes
var = R
x# = CDbl(interval) - 0.000001
cpt& = 1
ReDim T(1 To 2, 1 To cpt&)
For i& = 2 To UBound(var, 1)
If var(i&, 4) < x# Then
T(1, cpt&) = T(1, cpt&) + 1
T(2, cpt&) = T(2, cpt&) + var(i&, 4)
Else
x# = x# + CDbl(interval)
cpt& = cpt& + 1
ReDim Preserve T(1 To 2, 1 To cpt&)
T(1, cpt&) = T(1, cpt&) + 1
T(2, cpt&) = T(2, cpt&) + var(i&, 4)
End If
Next i&
S.Cells.Delete
Set R = S.Range(S.Cells(2, 1), S.Cells(UBound(T, 2) + 1, 2))
R = Application.WorksheetFunction.Transpose(T)
R.NumberFormat = "General"
Set R = S.Range("a1:c1")
R = Array("Nombre", "Somme", "Intervalle = " & interval & "")
R.Font.Bold = True
R.HorizontalAlignment = xlCenter
S.[a1].Select
S.Columns.AutoFit
End Sub |
Partager