admin 管理员组文章数量: 887021
2024年1月23日发(作者：如何恢复删掉的文件)
Sub setbar() '输出所有的工具栏，菜单栏
Dim cmdbar As CommandBar
Dim i As Integer
i = 1
For Each cmdbar In dBars
Cells(i, 1) =
Cells(i, 2) =
i = i + 1
Next
End Sub
Sub setbar()
dBars("Standard").Visible _
= Not dBars("Standard").Visible
End Sub
Sub setbar()
dBars(3).Visible _
= Not dBars("Standard").Visible
End Sub
Sub setbar()
dBars("Worksheet Menu Bar").Reset
With dBars("Worksheet Menu Bar")
With .(msoControlButton)
.Caption = "测试按钮"
.TooltipText = "这是自己添加的一个测试按钮"
.Style = msoButtonIconAndCaptionBelow
.FaceId = 5
End With
End With
End Sub
_______________________________________________________________________________
Function CPK(rs As Range, ucl As Double, lcl As Double) '计算CPK
Dim sigma As Double '西格玛
Dim T As Double '规格公差
Dim U As Double '规格中心值
Dim x As Double '样本均值
Dim Ca As Double
sigma = (rs) '计算西格玛
T = ucl - lcl
U = (ucl + lcl) / 2
x = e(rs)
If lcl = -1 Then '当单侧下限规程没有时
CPK = (T - x) / (sigma * 3)
End If
If ucl = -1 Then '当单侧上限规程没有时
CPK = (x - lcl) / (sigma * 3)
End If
If ucl <> -1 And lcl <> -1 Then '正常计算
Ca = (x - U) / (T / 2)
cp = T / (6 * sigma)
CPK = cp * (1 - Abs(Ca))
End If
If CPK < 0 Then '如果CPK小于0，则为0
CPK = 0
End If
End Function
'计算合格率
Function Pass(re As Range, ucl As Double, lcl As Double)
Dim passcount As Integer '合格个数
Dim passcent As Double '合格率
Dim allcount As Integer '总数
passcount = 0
passcent = 0
allcount =
For i = 1 To
For j = 1 To
If (i, j) = "" Or CDbl((i, j).Value) = False Then '如果不能转换成double型，或者为空，总数减一
allcount = allcount - 1
ElseIf CDbl((i, j).Value) >= lcl And CDbl((i, j).Value) <= ucl Then
'如果合格则合格数加1
passcount = passcount + 1
End If
Next j
Next i
If allcount <= 0 Then
MsgBox "总数为0了"
Else
passcent = passcount / allcount
End If
Pass = passcent
End Function
版权声明：本文标题：VBA常用代码 内容由网友自发贡献，该文观点仅代表作者本人， 转载请联系作者并注明出处：http://www.freenas.com.cn/jishu/1705986185h496766.html， 本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌抄袭侵权/违法违规的内容，一经查实，本站将立刻删除。
发表评论