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

fangqingyu

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 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
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 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 = "" 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 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 = "" 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 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 = "" 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 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 = "" 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 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 = "" 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 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 = "" 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:07
楼主自己写的吗？

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

fangqingyu

'***************************************功能： 函数帮助文件
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

chokokukin

fangqingyu 发表于 2018-10-22 21:24
在EXCEL内创建模块，复制粘贴进去就可以了，不清楚问一下百度，搜VBA

谢谢！额试试。

兴宜青石

楼主自己写的吗？

hunter5168

willwang

谢谢分享！

皮卡丘

软件代码？

caohuijian

叶太平

谢谢分享。。。

billye

谢谢分享。。。