原创—EXCEL VBA SPC自定义函数包括CPK PPK CP……
- 1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
- 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
- 3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。
'################## stdevR=average(max-min)/R系数组内差
Function stdevR(ParamArray rng() As Variant) As Variant
Dim rang As Range, rngi As Range, T As Single, F As Single, i As Integer, e As Integer
Dim trr
Dim arr()
Dim brr()
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
n = rang.Cells.Count
aa = rang.Columns.Count
bb = rang.Rows.Count
cc = Application.WorksheetFunction.Ceiling(n / 5, 1)
If aa > 1 Then
ReDim arr(1 To bb)
For i = 1 To bb
Set rngi = rang(i, 1).Resize(1, aa)
arr(i) = Application.Max(rngi.Value) - Application.Min(rngi)
Next
F = Application.WorksheetFunction.Average(arr)
trr =
[{0,1.128,1.693,2.059,2.326,2.534,2.704,2.847,2.97,3.078,3.173,3.258,3.336,3.407,3.472,3.532,3.58 8,3.64,3.689,3.735,3.778,3.819,3.858}]
T = trr(aa)
stdevR = F / T
Else
e = 0
ReDim brr(1 To cc)
For i = 1 To cc
Set rngi = rang(1, 1).Resize(5, 1).Offset(e, 0)
brr(i) = Application.Max(rngi.Value) - Application.Min(rngi)
e = e + 5
Next
F = Application.WorksheetFunction.Average(brr)
T = 2.326
stdevR = F / T
End If
End Function
'################## ppk=min(ppu,ppl)=(1-k)*pp 整体的过程能力指数带中心值的
Function ppk(USL As Variant, LSL As Variant, 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
SumN = SumN + Application.WorksheetFunction.Power(r - AV, 2)
Next
SE = Sqr(SumN / (n - 1))
k = Abs(((((USL + LSL) / 2) - AV) / (T / 2)))
If USL = "" And LSL = "" Or (1 - k) * T / (SE * 6) < 0 Then
ppk = "*"
Else
ppk = (1 - k) * T / (SE * 6)
End If
End Function
'################## cpk=min(cpu,cpl)=(1-k)*cp 组间的过程能力指数带中心值的Function cpk(USL As Variant, LSL As Variant, 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, aa 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
aa = rang.Columns.Count
AV = Application.WorksheetFunction.Average(rang)
SE = stdevR(rang)
k = Abs(((((USL + LSL) / 2) - AV) / (T / 2)))
If USL = "" And LSL = "" Or (1 - k) * (T / (SE * 6)) < 0 Then
cpk = "*"
Else
cpk = (1 - k) * (T / (SE * 6))
End If
End Function
'################## ppu=(USL-X)/3*S 上限过程能力指数
Function ppu(USL As Variant, 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
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