'################## 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.588,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 = \ 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 = \ 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
AV = Application.WorksheetFunction.Average(rang) For Each r In rang
SumN = SumN + Application.WorksheetFunction.Power(r - AV, 2) '计算平方和 Next
SE = Sqr(SumN / (n - 1))
If USL = \ ppu = \ Else
ppu = (USL - AV) / (3 * SE) End If
End Function
'################## ppu=(USL-X)/3*S 上限过程能力指数
Function CPU(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 aa = rang.Columns.Count
AV = Application.WorksheetFunction.Average(rang) SE = stdevR(rang)
If USL = \ CPU = \ Else
CPU = (USL - AV) / (3 * SE) End If
End Function
'################## ppl=(X-LSL)/3*S 下限过程能力指数
Function ppl(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 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) For Each r In rang
SumN = SumN + Application.WorksheetFunction.Power(r - AV, 2) '计算平方和 Next
SE = Sqr(SumN / (n - 1))
If LSL = \
ppl = \ Else
ppl = (AV - LSL) / (3 * SE) End If
End Function
Function cpl(LSL As Variant, ParamArray rng() As Variant) As Variant
Dim AV As Single, rang As Range, n As Single, 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
aa = rang.Columns.Count
AV = Application.WorksheetFunction.Average(rang) SE = stdevR(rang)
n = (AV - LSL) / (3 * SE) If LSL = \ cpl = \ Else cpl = n
End If
End Function
'################## k=((USL+LSL)/2)-X/(T/2) 偏移系数
Function k(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 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) If USL = \ k = \ Else
k = Application.WorksheetFunction.RoundUp(Abs(((USL + LSL) / 2) - AV) / (T / 2), 3) End If
End Function
'##################PP=(USL-LSL)/ 能力指数
Function pp(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 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))
If USL = \ pp = \ Else
pp = T / (SE * 6) End If
End Function
'################## CP=(USL-LSL)/6Q 能力指数
Function cp(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 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)
If USL = \ cp = \ Else
cp = T / (SE * 6) End If
End Function
'################## Fpu（cap）=1-NORMDIST（3*CPU) 超出规格上限概率 Function Fp(ByVal PU) As Variant Dim i As Double
If Application.WorksheetFunction.IsNumber(PU) = True Then i = 3 * PU
Fp = Format((1 - Application.WorksheetFunction.NormSDist(i)) * 1000000, \ Else Fp = 0 End If
'Fp = i '1 - Application.WorksheetFunction.NormSDist(i) End Function
'################## 正态随机数
Function RANDS(USL As Variant, LSL As Variant, WS As Variant, CPK As Variant, Optional JRS
原创—EXCEL VBA SPC自定义函数包括CPK PPK CP……
