Sub Test()
Dim dblStandardAbweichung
'Mittelwert wird im Makro berechnet
dblStandardAbweichung = fncStandardAbweichung(Range("B2:B13"))
MsgBox dblStandardAbweichung
'Mittelwert wird an Makro übergeben
dblStandardAbweichung = fncStandardAbweichung(Array(2, 4, 6, 8, 2.1, 3.9, 5.8, 8.1, _
1.95, 4.05, 6.1, 7.9), dblMittelwert:=10)
MsgBox dblStandardAbweichung
End Sub
Function fncStandardAbweichung(ByVal varWerte As Variant, Optional ByVal dblMittelwert = "") As _
Double
Dim wsfnc As WorksheetFunction
Dim dblSumSqrY As Double
Dim dblAnzahl As Double
Dim varElement As Variant
Set wsfnc = Application.WorksheetFunction
If Not IsNumeric(dblMittelwert) Then dblMittelwert = wsfnc.Average(varWerte)
For Each varElement In varWerte
dblAnzahl = dblAnzahl + 1
dblSumSqrY = dblSumSqrY + (varElement - dblMittelwert) ^ 2
Next
fncStandardAbweichung = (dblSumSqrY / dblAnzahl) ^ 0.5
End Function
Function Mittelwert2(intYear As Integer, strSheet As String)
Dim objX As Object, objY As Object
Dim arrX, arrY, lngX As Long
With Sheets(strSheet)
arrX = .Cells(8, 1).Resize(Application.Count(.Range(.Cells(8, 1), .Cells(Rows.Count, 1). _
_
End(xlUp))))
arrY = .Cells(8, 1).Resize(Application.Count(.Range(.Cells(8, 1), .Cells(Rows.Count, 1). _
_
End(xlUp)))).Offset(, 4)
End With
Set objX = CreateObject("Scripting.Dictionary")
Set objY = CreateObject("Scripting.Dictionary")
For lngX = LBound(arrX) To UBound(arrX)
If Year(arrX(lngX, 1)) = intYear Then
objX(lngX) = arrX(lngX, 1) * 1
objY(lngX) = arrY(lngX, 1) * 1
End If
Next lngX
Mittelwert2 = WorksheetFunction.Average(objY.items)
End Function
Function Steigung2(intYear As Integer, strSheet As String)
Dim objX As Object, objY As Object
Dim arrX, arrY, lngX As Long
With Sheets(strSheet)
arrX = .Cells(8, 1).Resize(Application.Count(.Range(.Cells(8, 1), .Cells(Rows.Count, 1). _
_
End(xlUp))))
arrY = .Cells(8, 1).Resize(Application.Count(.Range(.Cells(8, 1), .Cells(Rows.Count, 1). _
_
End(xlUp)))).Offset(, 4)
End With
Set objX = CreateObject("Scripting.Dictionary")
Set objY = CreateObject("Scripting.Dictionary")
For lngX = LBound(arrX) To UBound(arrX)
If Year(arrX(lngX, 1)) = intYear Then
objX(lngX) = arrX(lngX, 1) * 1
objY(lngX) = arrY(lngX, 1) * 1
End If
Next lngX
Steigung2 = WorksheetFunction.Slope(objY.items, objX.items)
End Function
'Erstellt unter Excel 2010
'Code in einem allgemeinen Modul
Option Explicit
Private objX As Object, objY As Object
Sub aatest()
Dim wsfnc As WorksheetFunction
Dim varSheets As Variant
Dim intJahr As Integer, varElement As Variant
Dim dblSteigung As Double, dblMittelwert1 As Double, dblMittelwert2 As Double
Dim dblStandAbw As Double
Dim rngX As Range
Set wsfnc = Application.WorksheetFunction
varSheets = Array(Worksheets("Tabelle1"))
For Each varElement In varSheets
For intJahr = 2007 To 2012
Call prcDatenObjekt_erzeugen(intYear:=intJahr, strSheet:=varElement.Name)
If objY.Count > 1 Then
dblMittelwert1 = wsfnc.Average(objY.items)
dblSteigung = wsfnc.Slope(objY.items, objX.items)
dblMittelwert2 = dblMittelwert1 * dblSteigung
dblStandAbw = fncStandardAbweichung(varWerte:=objY.items, dblMittelwert:=dblMittelwert1) _
MsgBox "Jahr: " & intJahr & vbLf _
& "Mittelwert1: " & dblMittelwert1 & vbLf _
& "Steigung: " & dblMittelwert1 & vbLf _
& "Mittelwert2: " & dblMittelwert2 & vbLf _
& "Standardabweichung: " & dblStandAbw & vbLf _
& "Anzahl Werte: " & objY.Count
Else
MsgBox "zu wenig Daten für Statistik im Jahr " & Format(intJahr, "0000") & vbLf _
& "Anzahl Werte: " & objY.Count
End If
Set objX = Nothing
Set objY = Nothing
Next
Set rngX = Nothing
Next
End Sub
Function fncStandardAbweichung(ByVal varWerte As Variant, Optional ByVal dblMittelwert = "") As _
Double
Dim dblSumSqrY As Double
Dim dblAnzahl As Double
Dim varElement As Variant
If Not IsNumeric(dblMittelwert) Then
dblMittelwert = Application.WorksheetFunction.Average(varWerte)
End If
For Each varElement In varWerte
dblAnzahl = dblAnzahl + 1
dblSumSqrY = dblSumSqrY + (varElement - dblMittelwert) ^ 2
Next
fncStandardAbweichung = (dblSumSqrY / dblAnzahl) ^ 0.5
End Function
Sub prcDatenObjekt_erzeugen(ByVal intYear As Integer, ByVal strSheet As String)
Dim arrX, arrY, lngX As Long
Set objX = Nothing
Set objY = Nothing
With Sheets(strSheet)
arrX = .Cells(8, 1).Resize(Application.WorksheetFunction.Count(.Range(.Cells(8, 1), _
.Cells(Rows.Count, 1).End(xlUp))))
arrY = .Cells(8, 1).Resize(Application.Count(.Range(.Cells(8, 1), _
.Cells(Rows.Count, 1).End(xlUp)))).Offset(, 4)
End With
Set objX = CreateObject("Scripting.Dictionary")
Set objY = CreateObject("Scripting.Dictionary")
For lngX = LBound(arrX) To UBound(arrX)
If Year(arrX(lngX, 1)) = intYear Then
objX(lngX) = arrX(lngX, 1) * 1
objY(lngX) = arrY(lngX, 1) * 1
End If
Next lngX
End Sub
Function Mittelwert2(ByVal intYear As Integer, ByVal strSheet As String)
Call prcDatenObjekt_erzeugen(intYear, strSheet)
Mittelwert2 = WorksheetFunction.Average(objY.items)
Set objX = Nothing
Set objY = Nothing
End Function
'Die Steigung berechne ich so:
Function Steigung2(ByVal intYear As Integer, ByVal strSheet As String)
Call prcDatenObjekt_erzeugen(intYear, strSheet)
Steigung2 = WorksheetFunction.Slope(objY.items, objX.items)
Set objX = Nothing
Set objY = Nothing
End Function
Die Datei https://www.herber.de/bbs/user/80622.xlsm wurde aus Datenschutzgründen gelöscht
Std. Abweichung_Gewichtet = Wurzel(Steigung*(X-Mittelwert(x))^2)