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