原创—VBA SPC函数完整版干货分享

fangqingyu 发表于 2018-10-21 23:59:06

EXCEL VBA 函数原创干货开源分享，知道用的人享福了!
'################## 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 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
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 AVAs 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 AVAs 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 = "" Or (USL - AV) / (3 * SE) < 0 Then
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 AVAs 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 = "" Or (USL - AV) / (3 * SE) < 0 Then
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 AVAs 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 = "" Or (AV - LSL) / (3 * SE) < 0 Then
ppl = "*"
Else
ppl = (AV - LSL) / (3 * SE)
End If
End Function
Function cpl(LSL As Variant, ParamArray rng() As Variant) As Variant
Dim AVAs 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 = "" Or n < 0 Then
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 AVAs 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 = "" Or LSL = "" Then
k = "*"
Else
k = Application.WorksheetFunction.RoundUp(Abs(((USL + LSL) / 2) - AV) / (T / 2), 3)
End If
End Function
'##################PP=(USL-LSL)/6S 能力指数
Function pp(USL As Variant, LSL As Variant, ParamArray rng() As Variant) As Variant
Dim AVAs 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 = "" Or LSL = "" Or T / (SE * 6) < 0 Then
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 AVAs 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 = "" Or LSL = "" Or T / (SE * 6) < 0 Then
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, "Fixed")
Else
Fp = 0
End If
'Fp = i '1 - Application.WorksheetFunction.NormSDist(i)
End Function

fangqingyu 发表于 2018-10-22 08:57:09

兴宜青石发表于 2018-10-22 08:07
楼主自己写的吗？

是的，就是我发布的EXCEL做直方图和控制图内的函数库。

fangqingyu 发表于 2018-10-22 00:01:05

'***************************************功能：函数帮助文件
Sub Fuhelp(control As IRibbonControl)
Dim 函数名称 As String    '函数名称
Dim 函数描述 As String    '函数描述
Dim 函数类别 As String    '函数类别
Dim 参数个数(2) As String '函数参数描述数组个数
Dim arr()
函数类别 = "品质使用函数"
参数个数(0) = "函数参数第1个，规格上限"
参数个数(1) = "函数参数第2个，规格下限"
参数个数(2) = "函数参数第3个，用于计算的数据区域"
ReDim arr(1 To 4)
arr = [{"cpk","ppk","cp","pp"}]
For i = 1 To 4
Call Application.MacroOptions(Macro:=arr(i), Description:=函数描述, Category:=函数类别, ArgumentDescriptions:=参数个数)
函数名称 = arr(i)
函数描述 = "返回数据的" & 函数名称 & "值"
Next i
End Sub

兴宜青石 发表于 2018-10-22 08:07:32

楼主自己写的吗？

hunter5168 发表于 2018-10-22 08:11:04

:):Q:Q:Q

willwang 发表于 2018-10-22 08:53:57

谢谢分享！

皮卡丘 发表于 2018-10-22 08:59:21

软件代码？

caohuijian 发表于 2018-10-22 09:01:42

叶太平 发表于 2018-10-22 09:09:43

谢谢分享。。。

billye 发表于 2018-10-22 09:24:30

谢谢分享。。。

页: [1] 2 3 4

品质协会(www.PinZhi.org)'s Archiver

原创—VBA SPC函数 完整版干货分享

原创—VBA SPC函数完整版干货分享