原创—EXCEL自定义函数完成CPK/PPK/CP/PP/CPU/CPL等的计算

fangqingyu

因为个人加载项文件功能较多包括直方图、帕拉图的宏自动汇制，现只分享部份做品质用的比较多的，自定义函数内容，会使用EXCEL加载项定义的同行朋友，这个原码，可以自己考过去用。再不用复杂的去用软件计算，只要在EXCEL内输入“=CPK(USL，LSL，要分析的数据区域)”回车就可以算出CPK值 了，其它的同理。如果其它的函数也需要，具体可以加QQ89702813讨论。
'################## PPK=min(ppu,ppl)=(1-k)*pp 整体的过程能力指数 带中心值的
Function ppk(USL As Single, LSL As Single, ParamArray rng() As Variant) As Variant
Dim AV  As Single, rang As Range, n As Integer, T As Single, SumN As Single, SE As Single, k As Single
For Each R In rng
If rang Is Nothing Then Set rang = R Else Set rang = Union(rang, R)
For Each c In R
Next
  Next
T = USL - LSL
n = rang.Cells.Count
AV = Application.WorksheetFunction.Average(rang)
For Each R In rang 'rng
     SumN = SumN + Application.WorksheetFunction.Power(R - AV, 2)
   Next
SE = Sqr(SumN / (n - 1)) '计算标准差SE
k = Abs(((((USL + LSL) / 2) - AV) / (T / 2)))
ppk = (1 - k) * T / (SE * 6)
End Function
'################## cpk=min(cpu,cpl)=(1-k)*cp 组间的过程能力指数 带中心值的
Function cpk(USL As Single, LSL As Single, ParamArray rng() As Variant) As Variant
Dim AV  As Single, rang As Range, n As Integer, T As Single, SumN As Single, SE As Single, k As Single
For Each R In rng
If rang Is Nothing Then Set rang = R Else Set rang = Union(rang, R)
For Each c In R
Next
  Next
T = USL - LSL
n = rang.Cells.Count
AV = Application.WorksheetFunction.Average(rang)
For Each R In rang 'rng
     SumN = SumN + Application.WorksheetFunction.Power(R - AV, 2)
   Next
SE = Sqr(SumN / n)
k = Abs(((((USL + LSL) / 2) - AV) / (T / 2)))
cpk = (1 - k) * (T / (SE * 6))
End Function

fangqingyu

'此过程用户注册自定义函数的帮助
Sub 帮助文件需要放在启动函数内()
    Dim 函数名称 As String        '函数名称
    Dim 函数描述 As String        '函数描述
    Dim 函数类别 As String        '函数类别
    Dim 参数个数(2) As String     '函数参数描述 数组 个数

     函数类别 = "品质使用函数"
    参数个数(0) = "函数参数第1个，规格上限"
    参数个数(1) = "函数参数第2个，规格下限"
    参数个数(2) = "函数参数第3个，用于计算的数据区域"
            函数名称 = "cpk"
            函数描述 = "返回数据的" & 函数名称 & "值"
        Call Application.MacroOptions(Macro:=函数名称, Description:=函数描述, Category:=函数类别, ArgumentDescriptions:=参数个数)
  
End Sub

damingcool

fangqingyu 发表于 2018-9-18 15:46
'此过程用户注册自定义函数的帮助
Sub 帮助文件需要放在启动函数内()
    Dim 函数名称 As String        ' ...

楼主能分享一下excel表格吗？谢谢！

shiyi152

这样写一串代码 大家应该看起来都会很懵  如果能够提供一个实例那就更好了

fangqingyu

干货！

李晨

flyerchang

谢谢分享

夏天的风520

Tiger-1

Hila

hunter5168

鄂F8888