注册 登录
Office中国论坛/Access中国论坛 返回首页

5988143的个人空间 http://www.office-cn.net/?10050 [收藏] [复制] [分享] [RSS]

日志

Statistical functions

已有 2477 次阅读2009-2-12 14:08 |

'Filters out variations of a data field, the numerical values and delivers them back. Possibly. 0-values are ignored
 
Public Function ZahlenFilter(ByVal varArr As Variant, Optional ByVal bolIgnoreZero As Boolean = False) As Variant
  Dim lngLB As Long, lngUB As Long, lngCnt As Long, lngVar As Long
  Dim dblVals() As Double

  lngLB = LBound(varArr)
  lngUB = UBound(varArr)
  For lngVar = lngLB To lngUB
    If IsNumeric(varArr(lngVar)) Then
      If Not bolIgnoreZero Or CDbl(varArr(lngVar)) <> 0 Then
        ReDim Preserve dblVals(0 To lngCnt)
        dblVals(lngCnt) = CDbl(varArr(lngVar))
        lngCnt = lngCnt + 1
      End If
    End If
  Next lngVar
  ZahlenFilter = dblVals
End Function

'Statistical Functions

Public Function Anzahl(ParamArray varVals() As Variant) As Long
  Anzahl = UBound(ZahlenFilter(varVals)) + 1
End Function

Public Function GeometrischesMittel(ParamArray varVals() As Variant) As Variant
  Dim lngUB As Long, lngVar As Long
  Dim dblGeo As Double
  Dim varArr As Variant

  varArr = ZahlenFilter(varVals)
  lngUB = UBound(varArr)
  dblGeo = 1
  For lngVar = 0 To lngUB
    If varArr(lngVar) < 0 Then
      GeometrischesMittel = Null
      Exit Function
    End If
    dblGeo = dblGeo * varArr(lngVar)
  Next lngVar
  GeometrischesMittel = dblGeo ^ (1 / (lngUB + 1))
End Function

Public Function Haeufigkeit(ByVal dblVal As Double, ParamArray varVals() As Variant) As Long
  Dim lngUB As Long, lngVar As Long, lngCnt As Long
  Dim varArr As Variant

  varArr = ZahlenFilter(varVals)
  lngUB = UBound(varArr)
  For lngVar = 1 To lngUB
    If varArr(lngVar) = dblVal Then lngCnt = lngCnt + 1
  Next lngVar
  Haeufigkeit = lngCnt
End Function

Public Function Maximum(ParamArray varVals() As Variant) As Double
  Dim lngUB As Long, lngVar As Long
  Dim dblMax As Double
  Dim varArr As Variant

  varArr = ZahlenFilter(varVals)
  lngUB = UBound(varArr)
  dblMax = varArr(0)
  For lngVar = 1 To lngUB
    If varArr(lngVar) > dblMax Then dblMax = varArr(lngVar)
  Next lngVar
  Maximum = dblMax
End Function

Public Function Median(ParamArray varVals() As Variant) As Double
  Dim lngUB As Long, lngVar1 As Long, lngVar2 As Long
  Dim dblVar As Double
  Dim varArr As Variant

  varArr = ZahlenFilter(varVals)
  lngUB = UBound(varArr)
  For lngVar1 = 0 To lngUB - 1
    For lngVar2 = lngVar1 + 1 To lngUB
      If varArr(lngVar1) > varArr(lngVar2) Then
        dblVar = varArr(lngVar1)
        varArr(lngVar1) = varArr(lngVar2)
        varArr(lngVar2) = dblVar
      End If
    Next lngVar2
  Next lngVar1
  If lngUB Mod 2 Then
    Median = (varArr((lngUB - 1) \ 2) + varArr((lngUB - 1) \ 2 + 1)) / 2
  Else
    Median = varArr(lngUB \ 2)
  End If
End Function

Public Function Minimum(ParamArray varVals() As Variant) As Double
  Dim lngUB As Long, lngVar As Long
  Dim dblMin As Double
  Dim varArr As Variant

  varArr = ZahlenFilter(varVals)
  lngUB = UBound(varArr)
  dblMin = varArr(0)
  For lngVar = 1 To lngUB
    If varArr(lngVar) < dblMin Then dblMin = varArr(lngVar)
  Next lngVar
  Minimum = dblMin
End Function

Public Function MittelAbweichung(ParamArray varVals() As Variant) As Double
  Dim lngUB As Long, lngVar As Long
  Dim dblAvg As Double, dblVar As Double
  Dim varArr As Variant

  varArr = ZahlenFilter(varVals)
  lngUB = UBound(varArr)
  For lngVar = 0 To lngUB
    dblAvg = dblAvg + varArr(lngVar)
  Next lngVar
  dblAvg = dblAvg / (lngUB + 1)
  For lngVar = 0 To lngUB
    dblVar = dblVar + Abs(varArr(lngVar) - dblAvg)
  Next lngVar
  MittelAbweichung = dblVar / (lngUB + 1)
End Function

Public Function Mittelwert(ParamArray varVals() As Variant) As Double
  Dim lngUB As Long, lngVar As Long
  Dim dblAvg As Double
  Dim varArr As Variant

  varArr = ZahlenFilter(varVals)
  lngUB = UBound(varArr)
  For lngVar = 0 To lngUB
    dblAvg = dblAvg + varArr(lngVar)
  Next lngVar
  Mittelwert = dblAvg / (lngUB + 1)
End Function

Public Function Modalwert(ParamArray varVals() As Variant) As Variant
  Dim lngUB As Long, lngVar1 As Long, lngVar2 As Long, lngCnts() As Long
  Dim dblMdl As Double
  Dim varArr As Variant

  varArr = ZahlenFilter(varVals)
  lngUB = UBound(varArr)
  ReDim lngCnts(0 To lngUB)
  For lngVar1 = 0 To lngUB - 1
    For lngVar2 = lngVar1 + 1 To lngUB
      If varArr(lngVar1) = varArr(lngVar2) Then lngCnts(lngVar1) = lngCnts(lngVar1) + 1
    Next lngVar2
  Next lngVar1
  lngVar1 = 0
  For lngVar2 = 1 To lngUB
    If lngCnts(lngVar1) < lngCnts(lngVar2) Then lngVar1 = lngVar2
  Next lngVar2
  For lngVar2 = 0 To lngUB
    If lngVar2 <> lngVar1 And lngCnts(lngVar2) = lngCnts(lngVar1) Then
      Modalwert = Null
      Exit Function
    End If
  Next lngVar2
  Modalwert = varArr(lngVar1)
End Function

Public Function Produkt(ParamArray varVals() As Variant) As Double
  Dim lngUB As Long, lngVar As Long
  Dim dblVar As Double
  Dim varArr As Variant

  varArr = ZahlenFilter(varVals)
  lngUB = UBound(varArr)
  dblVar = 1
  For lngVar = 0 To lngUB
    dblVar = dblVar * varArr(lngVar)
  Next lngVar
  Produkt = dblVar
End Function

Public Function QuadratMittel(ParamArray varVals() As Variant) As Double
  Dim lngUB As Long, lngVar As Long
  Dim dblVar As Double
  Dim varArr As Variant

  varArr = ZahlenFilter(varVals)
  lngUB = UBound(varArr)
  For lngVar = 0 To lngUB
    dblVar = dblVar + varArr(lngVar) ^ 2
  Next lngVar
  QuadratMittel = Sqr(dblVar / (lngUB + 1))
End Function

Public Function Summe(ParamArray varVals() As Variant) As Double
  Dim lngUB As Long, lngVar As Long
  Dim dblVar As Double
  Dim varArr As Variant

  varArr = ZahlenFilter(varVals)
  lngUB = UBound(varArr)
  For lngVar = 0 To lngUB
    dblVar = dblVar + varArr(lngVar)
  Next lngVar
  Summe = dblVar
End Function

Public Function Varianz(ParamArray varVals() As Variant) As Double
  Dim lngUB As Long, lngVar As Long
  Dim dblAvg As Double, dblVar As Double
  Dim varArr As Variant

  varArr = ZahlenFilter(varVals)
  lngUB = UBound(varArr)
  For lngVar = 0 To lngUB
    dblAvg = dblAvg + varArr(lngVar)
  Next lngVar
  dblAvg = dblAvg / (lngUB + 1)
  For lngVar = 0 To lngUB
    dblVar = dblVar + (varArr(lngVar) - dblAvg) ^ 2
  Next lngVar
  Varianz = dblVar / (lngUB + 1)
End Function

评论 (0 个评论)

facelist doodle 涂鸦板

您需要登录后才可以评论 登录 | 注册

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2024-4-20 07:01 , Processed in 0.063009 second(s), 16 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

返回顶部