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
