CPK工具源代码

2007/7/17更新

如果你需要此VBA加载宏,请访问 http://my.mofile.com/benjaminwan

或直接提取

简体中文:http://pickup.mofile.com/5505481867922136

繁体中文:http://pickup.mofile.com/0900889919321666

或许哪天有空,会详细写个教程……

以下是主要源代码

'==========变量定义==========
Dim sAVE, sStd, sMin, sMax, sCPK, sSL, sSC, sSU, sCPU, sCPL As Single
Dim iOffset As Integer
Dim err1 As String
Dim err2 As String
Dim err3 As String
Dim err4 As String
Dim err5 As String
Dim err6 As String
Dim err7 As String
Dim err8 As String
Dim err9 As String
Dim err10 As String
On Error GoTo errorzone
err1 = ThisWorkbook.Sheets("source").Range("A1").Value
err2 = ThisWorkbook.Sheets("source").Range("A2").Value
err3 = ThisWorkbook.Sheets("source").Range("A3").Value
err4 = ThisWorkbook.Sheets("source").Range("A4").Value
err5 = ThisWorkbook.Sheets("source").Range("A5").Value
err6 = ThisWorkbook.Sheets("source").Range("A6").Value
err7 = ThisWorkbook.Sheets("source").Range("A7").Value
err8 = ThisWorkbook.Sheets("source").Range("A8").Value
err9 = ThisWorkbook.Sheets("source").Range("A9").Value
err10 = ThisWorkbook.Sheets("source").Range("A10").Value
'==========是否选择了来源数据==========
If refData.Value = "" Then '无来源数据时的处理
'MsgBox "请选择数据来源!", vbOKOnly, "错误!"
msgbox err2, vbOKOnly, err1
refData.SetFocus
Exit Sub
ElseIf Range(refData.Value).Count <= 1 Then '来源数据太少时的处理
msgbox err3, vbOKOnly, err1
refData.SetFocus
Exit Sub
Else
'==========计算4项参数=========
sStd = Application.StDev(Range(refData.Value))
sMin = Application.Min(Range(refData.Value))
sMax = Application.Max(Range(refData.Value))
sAVE = Application.Average(Range(refData.Value))
If sStd = 0 Then
msgbox err4, vbOKOnly, err1
refData.SetFocus
Exit Sub
End If
End If
'==========是否计算CPK值=========
If chkCPK.Value = False Then
GoTo step3
Else
'==========双边规格上下限处理=========
If optDbside.Value = True Then
    If txtDup.Value = "" Then '未填写上限处理
    msgbox err5, vbOKOnly, err1
    txtDup.SetFocus
    Exit Sub
    ElseIf txtDdown.Value = "" Then '未填写下限处理
    msgbox err6, vbOKOnly, err1
    txtDdown.SetFocus
    Exit Sub
    Else
    sSU = val(txtDup.Value)
    sSL = val(txtDdown.Value)
        If sSU <= sSL Then '不合逻辑处理
        msgbox err7, vbOKOnly, err1
        txtDup.SetFocus
        Exit Sub
        Else
        sCPU = (sSU - sAVE) / 3 / sStd
        sCPL = (sAVE - sSL) / 3 / sStd
        sCPK = Application.Min(sCPU, sCPL)
        End If
    End If
End If
'==========单上限规格处理=========
If optSsideup.Value = True Then
    If txtSup.Value = "" Then '未填写上限处理
    msgbox err5, vbOKOnly, err1
    txtSup.SetFocus
    Exit Sub
    Else
    sSU = val(txtSup.Value)
    sCPK = (sSU - sAVE) / 3 / sStd
    End If
End If
'==========单下限规格处理=========
If optSsidedown.Value = True Then
    If txtSdwon.Value = "" Then '未填写下限处理
    msgbox err6, vbOKOnly, err1
    txtSdwon.SetFocus
    Exit Sub
    Else
    sSL = val(txtSdwon.Value)
    sCPK = (sAVE - sSL) / 3 / sStd
    End If
End If
End If
'==========屏幕刷新关闭,效率提升=========
Application.ScreenUpdating = False
'==========横排或竖排处理=========
step3:
iOffset = -1
Select Case togH.Value
Case True
'==========竖排处理=========
'写入平均值
If chkAve.Value = True Then
iOffset = iOffset + 1
If chkTitle.Value = True Then
With ActiveCell.Offset(iOffset, -1)
    .Value = "AVE"
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
With ActiveCell.Offset(iOffset, 0)
    .Formula = "=Average(" & refData.Value & ")"
    .Formula = Application.ConvertFormula(.Formula, xlA1, xlA1, xlRelative)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
'写入最小值
If chkMin.Value = True Then
iOffset = iOffset + 1
If chkTitle.Value = True Then
With ActiveCell.Offset(iOffset, -1)
    .Value = "MIN"
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
With ActiveCell.Offset(iOffset, 0)
    .Formula = "=MIN(" & refData.Value & ")"
    .Formula = Application.ConvertFormula(.Formula, xlA1, xlA1, xlRelative)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
'写入最大值
If chkMax.Value = True Then
iOffset = iOffset + 1
If chkTitle.Value = True Then
With ActiveCell.Offset(iOffset, -1)
    .Value = "MAX"
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
With ActiveCell.Offset(iOffset, 0)
    .Formula = "=MAX(" & refData.Value & ")"
    .Formula = Application.ConvertFormula(.Formula, xlA1, xlA1, xlRelative)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
'写入STDEV
If chkStd.Value = True Then
iOffset = iOffset + 1
If chkTitle.Value = True Then
With ActiveCell.Offset(iOffset, -1)
    .Value = "STDEV"
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
With ActiveCell.Offset(iOffset, 0)
    .Formula = "=STDEV(" & refData.Value & ")"
    .Formula = Application.ConvertFormula(.Formula, xlA1, xlA1, xlRelative)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
'写入CPK
If chkCPK.Value = True Then
iOffset = iOffset + 1
If chkTitle.Value = True Then
With ActiveCell.Offset(iOffset, -1)
    .Value = "CPK"
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
With ActiveCell.Offset(iOffset, 0)
    .Value = sCPK
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If

'==========横排排处理=========
Case False
'写入平均值
If chkAve.Value = True Then
iOffset = iOffset + 1
If chkTitle.Value = True Then
With ActiveCell.Offset(-1, iOffset)
    .Value = "AVE"
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
With ActiveCell.Offset(0, iOffset)
    .Formula = "=Average(" & refData.Value & ")"
    .Formula = Application.ConvertFormula(.Formula, xlA1, xlA1, xlRelative)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
'写入最小值
If chkMin.Value = True Then
iOffset = iOffset + 1
If chkTitle.Value = True Then
With ActiveCell.Offset(-1, iOffset)
    .Value = "MIN"
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
With ActiveCell.Offset(0, iOffset)
    .Formula = "=MIN(" & refData.Value & ")"
    .Formula = Application.ConvertFormula(.Formula, xlA1, xlA1, xlRelative)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
'写入最大值
If chkMax.Value = True Then
iOffset = iOffset + 1
If chkTitle.Value = True Then
With ActiveCell.Offset(-1, iOffset)
    .Value = "MAX"
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
With ActiveCell.Offset(0, iOffset)
    .Formula = "=MAX(" & refData.Value & ")"
    .Formula = Application.ConvertFormula(.Formula, xlA1, xlA1, xlRelative)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
'写入STDEV
If chkStd.Value = True Then
iOffset = iOffset + 1
If chkTitle.Value = True Then
With ActiveCell.Offset(-1, iOffset)
    .Value = "STDEV"
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
With ActiveCell.Offset(0, iOffset)
    .Formula = "=STDEV(" & refData.Value & ")"
    .Formula = Application.ConvertFormula(.Formula, xlA1, xlA1, xlRelative)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
'写入CPK
If chkCPK.Value = True Then
iOffset = iOffset + 1
If chkTitle.Value = True Then
With ActiveCell.Offset(-1, iOffset)
    .Value = "CPK"
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
With ActiveCell.Offset(0, iOffset)
    .Value = sCPK
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
End If
End Select
'=======================================================
Application.ScreenUpdating = True
Unload Me
Exit Sub
errorzone:
Select Case Err
    Case 11
    msgbox err9, vbOKOnly, err1
    Exit Sub
    Case Else
    msgbox err10 & Err, vbOKOnly, err1
    Exit Sub
End Select
End Sub

  • 0
    点赞
  • 1
    收藏
    觉得还不错? 一键收藏
  • 0
    评论

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值