ich stehe vor einem Problem das ich irgendwie nicht lösen kann. Dabei versuche ich mittels einer UDF den Mittelwert und die Std. Abweichung pro Std. berechnen. Leider ergibt mir meine Funktion den Wert 0% und nicht wie mauell berechnet 0.00004%. Ich verstehe nicht woran das liegt :(. Das Excel wie ich es maunell berechne kann hier gefunden werden:
https://www.herber.de/bbs/user/81871.xlsm
Leider ist das nur ein Ausschnitt und die Messung hat über 100k Zeilen deshalb würde ich es gerne als UDF machen. Die Funktion kann unten gefunden werden.
Danke für die Hilfe.
Viele Grüße,
Michael
Option Explicit
Private objX() As Variant, objY() As Variant, objZ() As Variant, lngCount As Long
'Gets the Data and performs the calculations
Sub GetData()
Calc ("Data")
End Sub
'
Function to calculate the Arithmetic Mean
Function Calc(strSheet As String) As Double
Dim dblSumAverage As Double
Dim varElement As Variant
Dim aktDate As Date
Dim aktHour As Long
'Dim cText As String
Call prcDatenObjekt_erzeugen(strSheet:=strSheet)
For varElement = 1 To lngCount - 1
aktDate = objX(varElement)
aktHour = Hour(objY(varElement))
If objX(varElement) > aktDate Or _
Hour(objY(varElement)) > aktHour Then
dblSumAverage = dblSumAverage + ((objZ(varElement + 1) - objZ(varElement)) / objZ( _
varElement))
End If
Next
dblSumAverage = dblSumAverage / (lngCount - 1)
ActiveSheet.Cells(3, 14).Value = dblSumAverage
Erase objX, objY, objZ
End Function
Sub prcDatenObjekt_erzeugen(ByVal strSheet As String)
Dim arrX, arrY, arrZ, lngX As Long
With Sheets(strSheet)
arrX = .Cells(5, 1).Resize(Application.WorksheetFunction.Count(.Range(.Cells(5, 1), _
.Cells(Rows.Count, 1).End(xlUp))))
arrY = .Cells(5, 1).Resize(Application.Count(.Range(.Cells(5, 1), _
.Cells(Rows.Count, 1).End(xlUp)))).Offset(, 1)
arrZ = .Cells(5, 1).Resize(Application.Count(.Range(.Cells(5, 1), _
.Cells(Rows.Count, 1).End(xlUp)))).Offset(, 2)
End With
lngCount = 0
For lngX = LBound(arrX) To UBound(arrX)
lngCount = lngCount + 1
ReDim Preserve objX(0 To lngCount)
ReDim Preserve objY(0 To lngCount)
ReDim Preserve objZ(0 To lngCount)
objX(lngCount) = arrX(lngX, 1) * 1
objY(lngCount) = arrY(lngX, 1) * 1
objZ(lngCount) = arrZ(lngX, 1) * 1
Next lngX
End Sub