原创—EXCEL VBA SPC自定义函数包括CPK PPK CP……

'################## stdevR=average(max-min)/R系数组内差Function stdevR(ParamArray rng() As Variant) As VariantDim rang As Range, rngi As Range, T As Single, F As Single, i As Integer, e As IntegerDim trrDim arr()Dim brr()For Each r In rngIf rang Is Nothing Then Set rang = r Else Set rang = Union(rang, r)For Each c In rNextNextn = rang.Cells.Countaa = rang.Columns.Countbb = rang.Rows.Countcc = Application.WorksheetFunction.Ceiling(n / 5, 1)If aa > 1 ThenReDim arr(1 To bb)For i = 1 To bbSet rngi = rang(i, 1).Resize(1, aa)arr(i) = Application.Max(rngi.Value) - Application.Min(rngi)NextF = 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 / TElsee = 0ReDim brr(1 To cc)For i = 1 To ccSet rngi = rang(1, 1).Resize(5, 1).Offset(e, 0)brr(i) = Application.Max(rngi.Value) - Application.Min(rngi)e = e + 5NextF = Application.WorksheetFunction.Average(brr)T = 2.326stdevR = F / TEnd IfEnd Function'################## ppk=min(ppu,ppl)=(1-k)*pp 整体的过程能力指数带中心值的Function ppk(USL As Variant, LSL As Variant, ParamArray rng() As Variant) As VariantDim AV As Single, rang As Range, n As Integer, T As Single, SumN As Single, SE As Single, k As SingleFor Each r In rngIf rang Is Nothing Then Set rang = r Else Set rang = Union(rang, r)For Each c In rNextNextT = USL - LSLn = rang.Cells.CountAV = Application.WorksheetFunction.Average(rang)For Each r In rangSumN = SumN + Application.WorksheetFunction.Power(r - AV, 2)NextSE = Sqr(SumN / (n - 1))k = Abs(((((USL + LSL) / 2) - AV) / (T / 2)))If USL = "" And LSL = "" Or (1 - k) * T / (SE * 6) < 0 Thenppk = "*"Elseppk = (1 - k) * T / (SE * 6)End IfEnd Function'################## cpk=min(cpu,cpl)=(1-k)*cp 组间的过程能力指数带中心值的Function cpk(USL As Variant, LSL As Variant, ParamArray rng() As Variant) As VariantDim AV As Single, rang As Range, n As Integer, T As Single, SumN As Single, SE As Single, k As Single, aa As SingleFor Each r In rngIf rang Is Nothing Then Set rang = r Else Set rang = Union(rang, r)For Each c In rNextNextT = USL - LSLn = rang.Cells.Countaa = rang.Columns.CountAV = 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 Thencpk = "*"Elsecpk = (1 - k) * (T / (SE * 6))End IfEnd Function'################## ppu=(USL-X)/3*S 上限过程能力指数Function ppu(USL As Variant, ParamArray rng() As Variant) As VariantDim AV As Single, rang As Range, n As Integer, T As Single, SumN As Single, SE As SingleFor Each r In rngIf rang Is Nothing Then Set rang = r Else Set rang = Union(rang, r)For Each c In rNextNextT = USL - LSLn = rang.Cells.CountAV = Application.WorksheetFunction.Average(rang)For Each r In rangSumN = SumN + Application.WorksheetFunction.Power(r - AV, 2) '计算平方和NextSE = Sqr(SumN / (n - 1))If USL = "" Or (USL - AV) / (3 * SE) < 0 Thenppu = "*"Elseppu = (USL - AV) / (3 * SE)End IfEnd Function'################## ppu=(USL-X)/3*S 上限过程能力指数Function CPU(USL As Variant, ParamArray rng() As Variant) As VariantDim AV As Single, rang As Range, n As Integer, T As Single, SumN As Single, SE As Single For Each r In rngIf rang Is Nothing Then Set rang = r Else Set rang = Union(rang, r)For Each c In rNextNextT = USL - LSLn = rang.Cells.Countaa = rang.Columns.CountAV = Application.WorksheetFunction.Average(rang)SE = stdevR(rang)If USL = "" Or (USL - AV) / (3 * SE) < 0 ThenCPU = "*"ElseCPU = (USL - AV) / (3 * SE)End IfEnd Function'################## ppl=(X-LSL)/3*S 下限过程能力指数Function ppl(LSL As Variant, ParamArray rng() As Variant) As VariantDim AV As Single, rang As Range, n As Integer, T As Single, SumN As Single, SE As Single For Each r In rngIf rang Is Nothing Then Set rang = r Else Set rang = Union(rang, r)For Each c In rNextNextT = USL - LSLn = rang.Cells.Countaa = rang.Columns.CountAV = Application.WorksheetFunction.Average(rang)For Each r In rangSumN = SumN + Application.WorksheetFunction.Power(r - AV, 2) '计算平方和NextSE = Sqr(SumN / (n - 1))If LSL = "" Or (AV - LSL) / (3 * SE) < 0 Thenppl = "*"Elseppl = (AV - LSL) / (3 * SE)End IfEnd FunctionFunction cpl(LSL As Variant, ParamArray rng() As Variant) As VariantDim AV As Single, rang As Range, n As Single, T As Single, SumN As Single, SE As Single For Each r In rngIf rang Is Nothing Then Set rang = r Else Set rang = Union(rang, r)For Each c In rNextNextT = USL - LSLaa = rang.Columns.CountAV = Application.WorksheetFunction.Average(rang)SE = stdevR(rang)n = (AV - LSL) / (3 * SE)If LSL = "" Or n < 0 Thencpl = "*"Elsecpl = nEnd IfEnd Function'################## k=((USL+LSL)/2)-X/(T/2) 偏移系数Function k(USL As Variant, LSL As Variant, ParamArray rng() As Variant) As VariantDim AV As Single, rang As Range, n As Integer, T As Single, SumN As Single, SE As Single For Each r In rngIf rang Is Nothing Then Set rang = r Else Set rang = Union(rang, r)For Each c In rNextNextT = USL - LSLn = rang.Cells.CountAV = Application.WorksheetFunction.Average(rang)If USL = "" Or LSL = "" Thenk = "*"Elsek = Application.WorksheetFunction.RoundUp(Abs(((USL + LSL) / 2) - AV) / (T / 2), 3)End IfEnd Function'##################PP=(USL-LSL)/ 能力指数Function pp(USL As Variant, LSL As Variant, ParamArray rng() As Variant) As VariantDim AV As Single, rang As Range, n As Integer, T As Single, SumN As Single, SE As Single For Each r In rngIf rang Is Nothing Then Set rang = r Else Set rang = Union(rang, r)For Each c In rNextNextT = USL - LSLn = rang.Cells.CountAV = Application.WorksheetFunction.Average(rang)For Each r In rang 'rngSumN = SumN + Application.WorksheetFunction.Power(r - AV, 2)NextSE = Sqr(SumN / (n - 1))If USL = "" Or LSL = "" Or T / (SE * 6) < 0 Thenpp = "*"Elsepp = T / (SE * 6)End IfEnd Function'################## CP=(USL-LSL)/6Q 能力指数Function cp(USL As Variant, LSL As Variant, ParamArray rng() As Variant) As VariantDim AV As Single, rang As Range, n As Integer, T As Single, SumN As Single, SE As SingleFor Each r In rngIf rang Is Nothing Then Set rang = r Else Set rang = Union(rang, r)For Each c In rNextNextT = USL - LSLn = rang.Cells.Countaa = rang.Columns.CountAV = Application.WorksheetFunction.Average(rang)SE = stdevR(rang)If USL = "" Or LSL = "" Or T / (SE * 6) < 0 Thencp = "*"Elsecp = T / (SE * 6)End IfEnd Function'################## Fpu（cap）=1-NORMDIST（3*CPU) 超出规格上限概率Function Fp(ByVal PU) As VariantDim i As DoubleIf Application.WorksheetFunction.IsNumber(PU) = True Theni = 3 * PUFp = Format((1 - Application.WorksheetFunction.NormSDist(i)) * 1000000, "Fixed")ElseFp = 0End 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 JRSAs Integer, Optional SEE As Integer) As VariantDim AV As Single, T As Single, Su As Single, SE As Single, k As SingleT = USL - LSLk = USL + LSLAV = k / 2If SEE = 0 ThenSE = T / CPK / 6ElseSE = T / CPK / SEEEnd IfSu = Application.WorksheetFunction.RoundUp(0.0000000000001, WS)If JRS = 0 ThenRANDS =Application.WorksheetFunction.RoundUp(Application.WorksheetFunction.Ceiling(Application.Wor ksheetFunction.NormInv(Rnd(), AV, SE), Su), WS)End IfIf JRS = 2 ThenRANDS =Application.WorksheetFunction.RoundUp(Application.WorksheetFunction.Ceiling(Application.Wor ksheetFunction.NormInv(Rnd(), AV, SE), Su * 2), WS)End IfIf JRS = 1 ThenRANDS =Application.WorksheetFunction.RoundUp(Application.WorksheetFunction.Ceiling(Application.Wor ksheetFunction.NormInv(Rnd(), AV, SE), Su * 2) + Su, WS)End IfEnd Function'***************************************功能：函数帮助文件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 4Call Application.MacroOptions(Macro:=arr(i), Description:=函数描述, Category:=函数类别, ArgumentDescriptions:=参数个数)函数名称 = arr(i)函数描述 = "返回数据的" & 函数名称 & "值"Next i End Sub。