品质协会(www.PinZhi.org)

 找回密码
 加入协会

QQ登录

只需一步,快速开始

查看: 25740|回复: 75

原创—EXCEL自定义函数完成CPK/PPK/CP/PP/CPU/CPL等的计算

  [复制链接]

18

主题

97

回帖

6

精华

品质协会高级会员

Rank: 4

积分
5246
品质币
5011
职位
1
发表于 2018-9-18 15:42:53 | 显示全部楼层 |阅读模式
因为个人加载项文件功能较多包括直方图、帕拉图的宏自动汇制,现只分享部份做品质用的比较多的,自定义函数内容,会使用EXCEL加载项定义的同行朋友,这个原码,可以自己考过去用。再不用复杂的去用软件计算,只要在EXCEL内输入“=CPK(USL,LSL,要分析的数据区域)”回车就可以算出CPK值 了,其它的同理。如果其它的函数也需要,具体可以加QQ89702813讨论。
'################## PPK=min(ppu,ppl)=(1-k)*pp 整体的过程能力指数 带中心值的
Function ppk(USL As Single, LSL As Single, 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 'rng
     SumN = SumN + Application.WorksheetFunction.Power(R - AV, 2)
   Next
SE = Sqr(SumN / (n - 1)) '计算标准差SE
k = Abs(((((USL + LSL) / 2) - AV) / (T / 2)))
ppk = (1 - k) * T / (SE * 6)
End Function
'################## cpk=min(cpu,cpl)=(1-k)*cp 组间的过程能力指数 带中心值的
Function cpk(USL As Single, LSL As Single, 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 'rng
     SumN = SumN + Application.WorksheetFunction.Power(R - AV, 2)
   Next
SE = Sqr(SumN / n)
k = Abs(((((USL + LSL) / 2) - AV) / (T / 2)))
cpk = (1 - k) * (T / (SE * 6))
End Function



1. 问答、交流探讨的帖子,回帖时,请不要发纯表情等无价值回帖,无意义,太多了影响用户体验,经常这样账号会被扣分甚至禁号的;
2. 品质协会是个学习、交流分享的平台,所有资料和内容归作者和版权方所有,需要正版标准、资料的请去相关的官方网站等平台购买。

18

主题

97

回帖

6

精华

品质协会高级会员

Rank: 4

积分
5246
品质币
5011
职位
2
 楼主| 发表于 2018-9-18 15:43:33 | 显示全部楼层
干货!

18

主题

97

回帖

6

精华

品质协会高级会员

Rank: 4

积分
5246
品质币
5011
职位
3
 楼主| 发表于 2018-9-18 15:46:22 | 显示全部楼层
'此过程用户注册自定义函数的帮助
Sub 帮助文件需要放在启动函数内()
    Dim 函数名称 As String        '函数名称
    Dim 函数描述 As String        '函数描述
    Dim 函数类别 As String        '函数类别
    Dim 参数个数(2) As String     '函数参数描述 数组 个数

     函数类别 = "品质使用函数"
    参数个数(0) = "函数参数第1个,规格上限"
    参数个数(1) = "函数参数第2个,规格下限"
    参数个数(2) = "函数参数第3个,用于计算的数据区域"
            函数名称 = "cpk"
            函数描述 = "返回数据的" & 函数名称 & "值"
        Call Application.MacroOptions(Macro:=函数名称, Description:=函数描述, Category:=函数类别, ArgumentDescriptions:=参数个数)
  
End Sub

18

主题

249

回帖

1

精华

品质协会高级会员

Rank: 4

积分
4256
品质币
3969
职位
4
居住地
河南省 南阳市
发表于 2018-9-19 07:55:12 | 显示全部楼层

62

主题

5万

回帖

5

精华

品质大师

Rank: 12Rank: 12Rank: 12

积分
108950
品质币
51814
职位
5
居住地
江苏省 无锡市
发表于 2018-9-19 08:54:43 | 显示全部楼层
谢谢分享

0

主题

235

回帖

0

精华

品质协会高级会员

Rank: 4

积分
16028
品质币
15793
职位
6
居住地
陕西省 宝鸡市 渭滨区 桥南街道
发表于 2018-9-19 09:07:31 | 显示全部楼层

0

主题

3401

回帖

0

精华

品质协会高级会员

Rank: 4

积分
17741
品质币
14340
职位
7
发表于 2018-9-19 09:11:20 | 显示全部楼层

1

主题

203

回帖

0

精华

品质协会高级会员

Rank: 4

积分
3902
品质币
3698
职位
8
发表于 2018-9-19 09:19:51 | 显示全部楼层

115

主题

6330

回帖

2

精华

品质协会主任会员

漂泊 尋根的迷途羔羊

Rank: 8Rank: 8

积分
24905
品质币
18420
职位
顧問師
居住地
台湾 台中市
发表于 2018-9-19 09:27:55 | 显示全部楼层
上班中;沒有不會做事的部屬 只有無能的主管。
微信號:hunter5168tw

3

主题

2194

回帖

0

精华

品质协会高级会员

Rank: 4

积分
7743
品质币
5546
职位
10
发表于 2018-9-19 10:34:26 | 显示全部楼层
您需要登录后才可以回帖 登录 | 加入协会

本版积分规则

《品质协会规则》|品质币|品质B2B|手机版|加入协会|联系我们|品质协会(www.PinZhi.org)

GMT+8, 2024-3-29 10:24 , Processed in 0.035442 second(s), 5 queries , Gzip On, Redis On.

Powered by 品质协会 © 2010-2024

品质人,让生活和环境变得更美好!!!

快速回复 返回顶部 返回列表