单分布图工具源代码

2007/7/17更新

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

或直接提取

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

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

Private Sub cmdYes_Click()
'==========变量定义==========
Dim oSL, oSC, oSU, oCPU, oCPL, oCA, NewWorksheet, NewChart, sheet_name, workbook_name, PosStart, PosEnd As Object
Dim sAVE, sL3CV, sU3CV, sStd, sMin, sMax, sCPK, sCP, sSkewness, sKurtosis, sDefect, sPPM, Xstep, Ystep, Data(), DistXmax, DistYmax, sYmax, Xdist(20), Ydist(20), Astep As Single
Dim x, y, iColumn_num, iColumn_count, iRow_num, iRow_count, iData_count As Integer
Const XSET As Integer = 26
Dim XSetData As Integer
XSetData = val(txtPosition.Value)
Xstep = val(txtXstep.Value)
Ystep = val(txtYstep.Value)
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
err9 = ThisWorkbook.Sheets("source").Range("A9").Value
err10 = ThisWorkbook.Sheets("source").Range("A10").Value
err11 = ThisWorkbook.Sheets("source").Range("A11").Value
'==========当前工作簿路径存储==========
sheet_name = ActiveSheet.Name
workbook_name = ActiveWorkbook.Name
'==========取得起始行和列，计算数据个数==========
iColumn_num = Workbooks(workbook_name).Sheets(sheet_name).Range(refData.Value).Column '起始列数
iRow_num = Workbooks(workbook_name).Sheets(sheet_name).Range(refData.Value).Row '起始行数
iColumn_count = Range(refData.Value).Columns.Count '计算列数
iRow_count = Range(refData.Value).Rows.Count  '计算行数
iData_count = Range(refData.Value).Count '计算数据个数
'==========是否选择了来源数据及是否单列==========
If refData.Value = "" Then '无来源数据时的处理
'MsgBox "请选择数据来源!", vbOKOnly, "错误!"
msgbox err2, vbOKOnly, err1
refData.SetFocus
Exit Sub
Else
'检测是否选择单列
If iColumn_count > 1 Or iRow_count < 2 Or iData_count < 2 Or iData_count <> iRow_count Then '大于1列或小于2行时
msgbox err11, vbOKOnly, err1
refData.SetFocus
Exit Sub
End If
End If
'==========复制数据到一维数组=========
'例15个变量的数组:Dim data(14)
ReDim Data(iData_count - 1) '重新定义数组长度
ReDim DistXmax(iData_count - 1)
ReDim DistYmax(iData_count - 1)
For x = 0 To iData_count - 1
Data(x) = Workbooks(workbook_name).Sheets(sheet_name).Cells(iRow_num + x, iColumn_num).Value
Data(x) = Application.Round(Data(x) / Ystep, 0) * Ystep
Next x
'==========计算4项重要参数=========
sAVE = Application.Average(Data)
sStd = Application.StDev(Data)
sMin = Application.Min(Data)
sMax = Application.Max(Data)
'==========双边规格上下限处理=========
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
    oSL = val(txtDdown.Value)
    oSU = val(txtDup.Value)
        If oSU <= oSL Then '不合逻辑处理
        msgbox err7, vbOKOnly, err1
        txtDup.SetFocus
        Exit Sub
        Else
        oSC = Application.Median(oSL, oSU) '计算中心值
        oCPU = (oSU - sAVE) / 3 / sStd
        oCPL = (sAVE - oSL) / 3 / sStd
        sCPK = Application.Min(oCPU, oCPL)
        sCP = (oSU - oSL) / 6 / sStd
        oCA = (oSC - sAVE) / (oSU - oSL) * 2
        If oCA < 0 Then
        oCA = -oCA
        End If
        End If
    End If
End If
'==========单上限规格处理=========
If optSsideup.Value = True Then
    If txtSup.Value = "" Then '未填写上限处理
    msgbox err5, vbOKOnly, err1
    txtSup.SetFocus
    Exit Sub
    Else
    oSU = val(txtSup.Value)
    oSL = ""
    oSC = ""
    oCPU = (oSU - sAVE) / 3 / sStd
    oCPL = "None"
    sCPK = oCPU
    sCP = sCPK
    oCA = "None"
    End If
End If
'==========单下限规格处理=========
If optSsidedown.Value = True Then
    If txtSdwon.Value = "" Then '未填写下限处理
    msgbox err6, vbOKOnly, err1
    txtSdwon.SetFocus
    Exit Sub
    Else
    oSL = val(txtSdwon.Value)
    oSU = ""
    oSC = ""
    oCPL = (sAVE - oSL) / 3 / sStd
    oCPU = "None"
    sCPK = oCPL
    sCP = sCPK
    oCA = "None"
    End If
End If
'==========屏幕刷新关闭，效率提升=========
Application.ScreenUpdating = False
'==========计算各参数=========
sL3CV = sAVE - 3 * sStd
sU3CV = sAVE + 3 * sStd
sSkewness = Application.Skew(Data)
sKurtosis = Application.Kurt(Data)
sDefect = 1 - Application.NormSDist(3 * sCPK)
sPPM = sDefect * 1000000
'==========新建工作簿=========
Set NewWorksheet = Worksheets.Add
'设置格式
With NewWorksheet
.Columns(XSetData + 1).ColumnWidth = 13
.Columns(XSetData + 2).ColumnWidth = 10
.Columns(XSetData + 3).ColumnWidth = 10
'横向打印
'With .PageSetup
'    .Orientation = xlLandscape
'End With
'设置线框
With .Range(Cells(1, XSetData + 1), Cells(20, XSetData + 3))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End With
'==========复制项目标题=========
For x = 1 To 20
NewWorksheet.Cells(x, XSetData + 1).Value = ThisWorkbook.Sheets("source").Range("B" & x).Value
NewWorksheet.Cells(x, XSetData + 2).Value = ThisWorkbook.Sheets("source").Range("C" & x).Value
Next x
'==========填入数值=========
NewWorksheet.Cells(1, XSetData + 3).Value = ThisWorkbook.Sheets("source").Range("D" & 1).Value
NewWorksheet.Cells(2, XSetData + 3).Value = iData_count
NewWorksheet.Cells(3, XSetData + 3).Value = oSL
NewWorksheet.Cells(4, XSetData + 3).Value = oSC
NewWorksheet.Cells(5, XSetData + 3).Value = oSU
NewWorksheet.Cells(6, XSetData + 3).Value = sL3CV
NewWorksheet.Cells(7, XSetData + 3).Value = sU3CV
NewWorksheet.Cells(8, XSetData + 3).Value = sAVE
NewWorksheet.Cells(9, XSetData + 3).Value = sMin
NewWorksheet.Cells(10, XSetData + 3).Value = sMax
NewWorksheet.Cells(11, XSetData + 3).Value = sStd
NewWorksheet.Cells(12, XSetData + 3).Value = oCPU
NewWorksheet.Cells(13, XSetData + 3).Value = oCPL
NewWorksheet.Cells(14, XSetData + 3).Value = sCP
NewWorksheet.Cells(15, XSetData + 3).Value = sCPK
NewWorksheet.Cells(16, XSetData + 3).Value = oCA
NewWorksheet.Cells(17, XSetData + 3).Value = sSkewness
NewWorksheet.Cells(18, XSetData + 3).Value = sKurtosis
NewWorksheet.Cells(19, XSetData + 3).Value = sDefect
NewWorksheet.Cells(20, XSetData + 3).Value = sPPM
NewWorksheet.Range(Cells(6, XSetData + 3), Cells(8, XSetData + 3)).NumberFormatLocal = "0.00_ "
NewWorksheet.Range(Cells(11, XSetData + 3), Cells(20, XSetData + 3)).NumberFormatLocal = "0.00_ "
NewWorksheet.Cells(16, XSetData + 3).NumberFormatLocal = "0.00%"
NewWorksheet.Cells(19, XSetData + 3).NumberFormatLocal = "0.0000%"
'==========临时数据标题=========
With NewWorksheet
.Cells(1, XSET + 1) = "Xstep"
.Cells(1, XSET + 2) = Xstep
.Cells(2, XSET + 1) = "Ystep"
.Cells(2, XSET + 2) = Ystep
.Cells(3, XSET + 1) = "X data"
.Cells(3, XSET + 2) = "Y data"
.Cells(3, XSET + 3) = "Ave"
.Cells(3, XSET + 4) = "SL"
.Cells(3, XSET + 5) = "SC"
.Cells(3, XSET + 6) = "SU"
.Cells(3, XSET + 7) = "-3CV"
.Cells(3, XSET + 8) = "+3CV"
.Cells(3, XSET + 9) = "NormDist"
End With
'==========X坐标数据=========
x = 15
For y = 0 To iData_count - 1
x = x + 1
Cells(x, XSET + 1) = Data(y)
Next y
'==========Y坐标数据=========
x = 15
DistXmax = -999
For y = 0 To iData_count - 1
x = x + 1
    If y = 0 Then
    Set PosStart = NewWorksheet.Cells(x, XSET + 1)
    End If
    Set PosEnd = NewWorksheet.Cells(x, XSET + 1)
    NewWorksheet.Cells(x, XSET + 2) = Application.CountIf(NewWorksheet.Range(PosStart, PosEnd), PosEnd) * Xstep
    If NewWorksheet.Cells(x, XSET + 2) > DistXmax Then
    DistXmax = NewWorksheet.Cells(x, XSET + 2)
    End If
Next y
sYmax = DistXmax * 2
Call UnderLine(x, x, XSET + 1, XSET + 9)
'==========平均值X坐标数据=========
With NewWorksheet
.Cells(4, XSET + 1) = sAVE
.Cells(4, XSET + 3) = 0
.Cells(5, XSET + 1) = sAVE
.Cells(5, XSET + 3) = sYmax
Call UnderLine(5, 5, XSET + 1, XSET + 9)
'==========SL_坐标数据=========
.Cells(6, XSET + 1) = oSL
.Cells(6, XSET + 4) = 0
.Cells(7, XSET + 1) = oSL
.Cells(7, XSET + 4) = sYmax
Call UnderLine(7, 7, XSET + 1, XSET + 9)
'==========SC_坐标数据=========
.Cells(8, XSET + 1) = oSC
.Cells(8, XSET + 5) = 0
.Cells(9, XSET + 1) = oSC
.Cells(9, XSET + 5) = sYmax
Call UnderLine(9, 9, XSET + 1, XSET + 9)
'==========SU_坐标数据=========
.Cells(10, XSET + 1) = oSU
.Cells(10, XSET + 6) = 0
.Cells(11, XSET + 1) = oSU
.Cells(11, XSET + 6) = sYmax
Call UnderLine(11, 11, XSET + 1, XSET + 9)
'==========-3CV_坐标数据=========
.Cells(12, XSET + 1) = sL3CV
.Cells(12, XSET + 7) = 0
.Cells(13, XSET + 1) = sL3CV
'.Cells(13, XSET + 7) = sYmax
.Cells(13, XSET + 7) = 0.5
Call UnderLine(13, 13, XSET + 1, XSET + 9)
'==========+3CV_坐标数据=========
.Cells(14, XSET + 1) = sU3CV
.Cells(14, XSET + 8) = 0
.Cells(15, XSET + 1) = sU3CV
'.Cells(15, XSET + 8) = sYmax
.Cells(15, XSET + 8) = 0.5
Call UnderLine(15, 15, XSET + 1, XSET + 9)
End With
'==========正态分布曲线坐标=========
DistYmax = -999
Astep = (sU3CV - sL3CV) / 20
For y = 0 To 20
    Xdist(y) = sL3CV + (y) * Astep
    Ydist(y) = Application.NormDist(Xdist(y), sAVE, sStd, False)
    If Ydist(y) > DistYmax Then
    DistYmax = Ydist(y)
    End If
Next y
For I = 0 To 20
    Cells(x + I + 1, XSET + 9) = Ydist(I) / DistYmax * (DistXmax + 2 * Xstep)  '2为高度，越大越高
    Cells(x + I + 1, XSET + 1) = Xdist(I)
Next I
'==========加粗数据边框=========
Set PosStart = Cells(3, XSET + 1)
Set PosEnd = Cells(x + I, XSET + 9)
Range(PosStart, PosEnd).Select
With Selection.Borders(xlLeft)
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With
Selection.BorderAround LineStyle:=xlNone
With Selection.Borders(xlLeft)
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With
Selection.BorderAround Weight:=xlMedium, ColorIndex:=xlAutomatic
'==========绘制分布图=========
ActiveSheet.ChartObjects.Add(0, 0, 450, 250).Select
Application.CutCopyMode = False
ActiveChart.ChartWizard source:=Range(PosStart, PosEnd), Gallery:= _
xlXYScatter, Format:=1, PlotBy:=xlColumns, CategoryLabels:=1, _
SeriesLabels:=1, HasLegend:=2, Title:="", CategoryTitle:="", _
ValueTitle:="", ExtraTitle:=""
'设置绘图区颜色
ActiveSheet.ChartObjects(1).Activate
ActiveChart.PlotArea.Select
With Selection.Border
'    .ColorIndex = 1
    .Weight = xlThin
    .LineStyle = xlContinuous
End With
Selection.Interior.ColorIndex = xlNone
'ActiveChart.Legend.Position = xlBottom
'设置点的形态和颜色
ActiveChart.SeriesCollection(1).Select
With Selection.Border
    .Weight = xlThin
    .LineStyle = xlNone
End With
With Selection
    .MarkerBackgroundColorIndex = 2
    .MarkerForegroundColorIndex = 25
    .MarkerStyle = xlCircle
    .MarkerSize = 6 '点的大小
    .Smooth = False
End With
'绘制平均值线
ActiveChart.SeriesCollection(2).Select
With Selection.Border
    .ColorIndex = 3
    '.Weight = xlMedium
    .Weight = xlThin
    '.LineStyle = xlContinuous
    .LineStyle = xlDot
End With
With Selection
    .MarkerBackgroundColorIndex = 3
    .MarkerForegroundColorIndex = 3
    '.MarkerStyle = xlDiamond
    .MarkerStyle = xlNone
    .Smooth = False
End With
If ChkBox2.Value = True Then
ActiveChart.SeriesCollection(2).Points(2).ApplyDataLabels AutoText:=True, ShowSeriesName:=True
ActiveChart.SeriesCollection(2).DataLabels.Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Position = xlLabelPositionAbove
    .Orientation = xlHorizontal
End With
End If
'设置规格上下限和规格中心值
If optDbside.Value = True Then
For y = 1 To 3
ActiveChart.SeriesCollection(y + 2).Select
With Selection.Border
    .ColorIndex = 1
    .Weight = xlThin
    .LineStyle = xlDot
End With
With Selection
    .MarkerBackgroundColorIndex = 27
    .MarkerForegroundColorIndex = 27
    .MarkerStyle = xlNone
    .Smooth = False
End With
If ChkBox2.Value = True Then
ActiveChart.SeriesCollection(y + 2).Points(2 + y * 2).Select
ActiveChart.SeriesCollection(y + 2).Points(2 + y * 2).ApplyDataLabels AutoText:=True, ShowSeriesName:=True
ActiveChart.SeriesCollection(y + 2).DataLabels.Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Position = xlLabelPositionAbove
    .Orientation = xlHorizontal
End With
End If
Next y
End If
If optSsideup.Value = True Then
ActiveChart.SeriesCollection(5).Select
With Selection.Border
    .ColorIndex = 1
    .Weight = xlThin
    .LineStyle = xlDot
End With
With Selection
    .MarkerBackgroundColorIndex = 27
    .MarkerForegroundColorIndex = 27
    .MarkerStyle = xlNone
    .Smooth = False
End With
If ChkBox2.Value = True Then
ActiveChart.SeriesCollection(5).Points(8).Select
ActiveChart.SeriesCollection(5).Points(8).ApplyDataLabels AutoText:=True, ShowSeriesName:=True
ActiveChart.SeriesCollection(5).DataLabels.Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Position = xlLabelPositionAbove
    .Orientation = xlHorizontal
End With
End If
End If
If optSsidedown.Value = True Then
ActiveChart.SeriesCollection(3).Select
With Selection.Border
    .ColorIndex = 1
    .Weight = xlThin
    .LineStyle = xlDot
End With
With Selection
    .MarkerBackgroundColorIndex = 27
    .MarkerForegroundColorIndex = 27
    .MarkerStyle = xlNone
    .Smooth = False
End With
If ChkBox2.Value = True Then
ActiveChart.SeriesCollection(3).Points(4).Select
ActiveChart.SeriesCollection(3).Points(4).ApplyDataLabels AutoText:=True, ShowSeriesName:=True
ActiveChart.SeriesCollection(3).DataLabels.Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Position = xlLabelPositionAbove
    .Orientation = xlHorizontal
End With
End If
End If
'设置上下管制线
For y = 1 To 2
    ActiveChart.SeriesCollection(5 + y).Select
    With Selection.Border
        .ColorIndex = 1
        .Weight = xlThin
        .LineStyle = xlContinuous
'        .LineStyle = xlDot
    End With
    With Selection
        .MarkerBackgroundColorIndex = 30
        .MarkerForegroundColorIndex = 1
'        .MarkerStyle = xlDash
        .MarkerStyle = xlNone
        .Smooth = False
    End With
If ChkBox2.Value = True Then
ActiveChart.SeriesCollection(y + 5).Points(8 + y * 2).Select
ActiveChart.SeriesCollection(y + 5).Points(8 + y * 2).ApplyDataLabels AutoText:=True, ShowSeriesName:=True
ActiveChart.SeriesCollection(y + 5).DataLabels.Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Position = xlLabelPositionAbove
    .Orientation = xlHorizontal
End With
End If
Next y
'设置正态分布曲线
If ChkBox.Value = True Then
    ActiveChart.SeriesCollection(8).Select
    With Selection.Border
        .ColorIndex = 1
        .Weight = xlThin
        .LineStyle = xlContinuous
    End With
    With Selection
        .MarkerBackgroundColorIndex = xlNone
        .MarkerForegroundColorIndex = 32
        .MarkerStyle = xlNone
        .Smooth = True
    End With
Else
    ActiveChart.SeriesCollection(8).Select
    With Selection.Border
        .ColorIndex = xlNone
        .Weight = xlThin
        .LineStyle = xlNone
    End With
    With Selection
        .MarkerBackgroundColorIndex = xlNone
        .MarkerForegroundColorIndex = xlNone
        .MarkerStyle = xlNone
        .Smooth = True
    End With
End If
'=======================================================
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