原创—EXCEL自定义函数完成CPK/PPK/CP/PP/CPU/CPL等的计算
因为个人加载项文件功能较多包括直方图、帕拉图的宏自动汇制，现只分享部份做品质用的比较多的，自定义函数内容，会使用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 AVAs 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 AVAs 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
干货！ '此过程用户注册自定义函数的帮助
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 :Q 谢谢分享 :Q:Q:Q :Q:Q :Q:Q :) :Q:lol