我的统计质量控制图VB代码出错

时间：2014-12-03 19:47:52

标签： excel vba excel-vba charts controls

我在网上发现了一个在线创建统计质量控制图表的宏。所以我有一个看起来像excel表的.Csv文件。我使用宏，所以我必须选择数据点。然后我必须选择标签，然后绘制它。

我的问题是UL2的误差条=（上限，2 *标准差）和LL2 =（下限，2 *标准偏差）根本没有出现。所有其他错误栏都会显示出来。如平均值，UL（上限）和LL（下限）以及UL3和LL3，但不是UL2和LL2。

此外，数据点不在它们应该是的平均线上，它们也会移位。

我使用的样本表显示了它们，但这是在常规的excel文件中。我把它作为.CSV文件的原因，因为我使用另一个宏来提取原始数据，并将其粘贴到新的.csv文件中。我认为这是原因，但我不是百分百肯定。我想知道你们是否可以帮助我。我对VBA很新，所以请耐心等待。

谢谢！

以下是创建控制图的代码：

Option Explicit

Public Function GetRange(box_message As String) As Range
    Set GetRange = Nothing
    On Error Resume Next
    Set GetRange = Application.InputBox(box_message, "Select Range", Selection.Address, , , , , 8)
End Function

Public Function IsNotOk(ByVal rng As Range) As Boolean 'TO CHECK IF A GIVEN RANGE IS BLANK
    IsNotOk = True
    On Error GoTo if_error_occured:
    If rng.Rows.Count > 0 And rng.Columns.Count = 1 Then IsNotOk = False
if_error_occured:
    If Err.Number Then IsNotOk = True
End Function

Public Function check_if_numeric(rng As Range) As Boolean
Dim cel As Range
check_if_numeric = True
For Each cel In rng.Cells
    If Not (Application.WorksheetFunction.IsNumber(cel.Value)) Then check_if_numeric = False
Next cel
End Function

Sub make_control_chart()
    Dim data_values As Range
    Dim chart_labels As Range
    Dim range_selected_before As Range
    Dim got_label_range As Boolean
    Dim got_value_range As Boolean
    Dim bActivate As Boolean
    Dim myChtObj As ChartObject
    Dim plot_series, MyNewSrs As Series
    Dim series_label As String
    Dim number_of_control_limits As Integer
    Dim standard_deviation As Integer
    Dim data_str As String
    Dim avg_str As String

    On Error GoTo if_error_occured: 'GOTO THE END OF THE PROGRAM

    'GET RANGE FOR DATA VALUES
    bActivate = False   ' True to re-activate the input range
    Set data_values = GetRange("Please select the range containing the DATA POINTS" & Chr(13) & "(press select a single column)")
    If IsNotOk(data_values) Then
        MsgBox "Incorrect Input Data !"
        End
    ElseIf Not (check_if_numeric(data_values)) Then
        MsgBox "Incorrect Input Data !"
        End
    End If

    'GET RANGE FOR CHART X-AXIS LABELS
    got_label_range = True   ' True to re-activate the input range
    Set chart_labels = GetRange("Please select the range containing the LABELS" & Chr(13) & "(press ESC if no labels available)")
    If IsNotOk(chart_labels) Then
        got_label_range = False
    End If


    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual



    'LETS CREATE THE CHART NOW
    Set myChtObj = ActiveSheet.ChartObjects.Add(Left:=300, Width:=450, Top:=25, Height:=300)
    myChtObj.Chart.ChartType = xlLineMarkers


    'REMOVE ALL UNWANTED SERIES FROM CHART, IF ANY
    For Each MyNewSrs In myChtObj.Chart.SeriesCollection ' myChtObj.Chart.SeriesCollection
        MyNewSrs.Delete
    Next MyNewSrs
    Set MyNewSrs = Nothing


    If got_label_range Then 'IF WE HAVE THE LABEL RANGE
    'ADD NEW SERIES
        Set MyNewSrs = myChtObj.Chart.SeriesCollection.NewSeries
        With MyNewSrs
            .Name = "PLOT"
            .Values = data_values
            .XValues = chart_labels.Value
        End With
    Else
        Set MyNewSrs = myChtObj.Chart.SeriesCollection.NewSeries
        With MyNewSrs
            .Name = "PLOT"
            .Values = data_values
        End With
    End If

    'FORMAT THE PLOT SERIES
    Set plot_series = MyNewSrs
    With MyNewSrs
        .Border.ColorIndex = 1
        .MarkerBackgroundColorIndex = 2
        .MarkerForegroundColorIndex = xlAutomatic
        .MarkerStyle = xlCircle
        .Smooth = False
        .MarkerSize = 5
        .Shadow = False
    End With
    Set MyNewSrs = Nothing





    'CREATE NAMED RANGE FOR THE DATA VALUES, AVERAGE, LOWER AND UPPER CONTROL LIMITS
    data_str = Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_data_values"
    avg_str = "roundup(average(" & Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_data_values" & "),2)"

    ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_data_values", RefersToR1C1:=data_values
    ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_AVG", RefersToR1C1:="=" & avg_str & ""
    ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_LCL1", RefersToR1C1:="=" & avg_str & "- roundup(1*stdev(" & data_str & "),2)"
    ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_LCL2", RefersToR1C1:="=" & avg_str & "- roundup(2*stdev(" & data_str & "),2)"
    ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_LCL3", RefersToR1C1:="=" & avg_str & "- roundup(3*stdev(" & data_str & "),2)"
    ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_UCL1", RefersToR1C1:="=" & avg_str & "+ roundup(1*stdev(" & data_str & "),2)"
    ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_UCL2", RefersToR1C1:="=" & avg_str & "+ roundup(2*stdev(" & data_str & "),2)"
    ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_UCL3", RefersToR1C1:="=" & avg_str & "+ roundup(3*stdev(" & data_str & "),2)"



    'ADD THE LINE FOR AVERAGE
    Set MyNewSrs = myChtObj.Chart.SeriesCollection.NewSeries

    With MyNewSrs
        .Name = "AVG = "
        .Values = "='" & ActiveSheet.Name & "'!" & Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_AVG"
        .ChartType = xlXYScatter
        '.ErrorBar Direction:=xlX, Include:=xlNone, Type:=xlFixedValue, Amount:=10000
        '.ErrorBar Direction:=xlX, Include:=xlUp, Type:=xlFixedValue, Amount:=20
        .ErrorBar Direction:=xlX, Include:=xlPlusValues, Type:=xlFixedValue, Amount:=data_values.Rows.Count
        .MarkerBackgroundColorIndex = xlAutomatic
        .MarkerForegroundColorIndex = xlAutomatic
        .MarkerStyle = xlNone
        .Smooth = False
        .MarkerSize = 5
        .Shadow = False
        With .Border
            .Weight = xlHairline
            .LineStyle = xlNone
        End With
        'With .ErrorBars.Border
        '    .LineStyle = xlContinuous
        '    .ColorIndex = 3
        '    .Weight = xlThin
        'End With
    End With



    Set MyNewSrs = Nothing

    'ADD UPPER AND LOWER CONTROL LIMITS
     For number_of_control_limits = 1 To 3
        For standard_deviation = -1 To 1 Step 2

            Select Case standard_deviation:
                Case -1: series_label = "LCL"
                Case 1: series_label = "UCL"
            End Select

            Set MyNewSrs = myChtObj.Chart.SeriesCollection.NewSeries
            With MyNewSrs
                .Name = series_label & number_of_control_limits & " ="
                .Values = "='" & ActiveSheet.Name & "'!" & Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_" & series_label & number_of_control_limits
                .ChartType = xlXYScatter
                .ErrorBar Direction:=xlX, Include:=xlPlusValues, Type:=xlFixedValue, Amount:=data_values.Rows.Count
            End With

            MyNewSrs.ErrorBar Direction:=xlX, Include:=xlPlusValues, Type:=xlFixedValue, Amount:=data_values.Rows.Count

            Select Case number_of_control_limits:
                Case 1:
                            With MyNewSrs.ErrorBars.Border
                                .LineStyle = xlGray25
                                .ColorIndex = 15
                                .Weight = xlHairline
                            End With
                Case 2:
                            With MyNewSrs.ErrorBars.Border
                                .LineStyle = xlGray25
                                .ColorIndex = 57
                                .Weight = xlHairline
                            End With
                Case 3:
                            With MyNewSrs.ErrorBars.Border
                                .LineStyle = xlGray75
                                .ColorIndex = 3
                                .Weight = xlHairline
                            End With
            End Select

            MyNewSrs.ErrorBars.EndStyle = xlNoCap

            With MyNewSrs
                With .Border
                    .Weight = xlHairline
                    .LineStyle = xlNone
                End With
                .MarkerBackgroundColorIndex = xlAutomatic
                .MarkerForegroundColorIndex = xlAutomatic
                .MarkerStyle = xlNone
                .Smooth = False
                .MarkerSize = 5
                .Shadow = False
            End With
            Set MyNewSrs = Nothing
        Next standard_deviation
    Next number_of_control_limits

   myChtObj.Chart.ApplyDataLabels AutoText:=True, LegendKey:=False, _
        HasLeaderLines:=False, ShowSeriesName:=True, ShowCategoryName:=False, _
        ShowValue:=True, ShowPercentage:=False, ShowBubbleSize:=False, Separator:=" "

    'OFFSET THE LABELS
    For Each MyNewSrs In myChtObj.Chart.SeriesCollection
        With MyNewSrs.Points(1).DataLabel
            .Left = 400
        End With
    Next MyNewSrs


    'LETS FORMAT THE CHART
    With myChtObj
        With .Chart.Axes(xlCategory)
            .MajorTickMark = xlNone
            .MinorTickMark = xlNone
            .TickLabelPosition = xlNextToAxis
        End With
        With .Chart.Axes(xlValue)
            .MajorTickMark = xlOutside
            .MinorTickMark = xlNone
            .TickLabelPosition = xlNextToAxis
        End With
        With .Chart.ChartArea.Border
            .Weight = 1
            .LineStyle = 0
        End With
        With .Chart.PlotArea.Border
            .ColorIndex = 1
            .Weight = xlThin
            .LineStyle = xlContinuous
        End With
        With .Chart.PlotArea.Interior
            .ColorIndex = 2
            .PatternColorIndex = 1
            .Pattern = xlSolid
        End With
        With .Chart.ChartArea.Font
            .Name = "Arial"
            .Size = 8
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
            .Background = xlAutomatic
        End With
        With .Chart
            .HasTitle = False
            .Axes(xlCategory, xlPrimary).HasTitle = False
            .Axes(xlValue, xlPrimary).HasTitle = True
            .HasTitle = True
            .ChartTitle.Characters.Text = "Control Chart"
            .ChartTitle.Left = 134
            .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Observations"
        End With
        With .Chart.Axes(xlCategory).TickLabels
            .Alignment = xlCenter
            .Offset = 100
            .ReadingOrder = xlContext
            .Orientation = xlHorizontal
        End With
    End With



    myChtObj.Chart.Legend.Delete
    myChtObj.Chart.PlotArea.Width = 310
    myChtObj.Chart.Axes(xlValue).MajorGridlines.Delete
    myChtObj.Chart.Axes(xlValue).CrossesAt = myChtObj.Chart.Axes(xlValue).MinimumScale
    myChtObj.Chart.ChartArea.Interior.ColorIndex = xlAutomatic
    myChtObj.Chart.ChartArea.AutoScaleFont = True


    'DELETE THE LABELS FOR THE ACTUAL DATA SERIES
    plot_series.DataLabels.Delete
    Set plot_series = Nothing

if_error_occured:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    If Err.Number Then z_delete_all_named_range

End Sub


Sub z_delete_all_named_range()
Dim nam As Name
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    For Each nam In ActiveWorkbook.Names
    nam.Delete
    Next nam
End Sub

This is how it looks like when I plot it

这是我绘制时的样子。 UL2和LL2的错误栏甚至不存在。

1 个答案:

答案 0 :(得分：1)

因此，舍入后LCL1和LCL2似乎是相同的值（以及UCL1 / UCL2）。上面的综合函数舍入到只有两位小数。要查看它们的区别，请将舍入值从2位小数更改为3或4.建议将平均值更改为3/4小数位以匹配，但更新后的代码如下所示。

ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_LCL1", RefersToR1C1:="=" & avg_str & "- roundup(1*stdev(" & data_str & "),3)"
    ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_LCL2", RefersToR1C1:="=" & avg_str & "- roundup(2*stdev(" & data_str & "),3)"
    ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_LCL3", RefersToR1C1:="=" & avg_str & "- roundup(3*stdev(" & data_str & "),3)"
    ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_UCL1", RefersToR1C1:="=" & avg_str & "+ roundup(1*stdev(" & data_str & "),3)"
    ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_UCL2", RefersToR1C1:="=" & avg_str & "+ roundup(2*stdev(" & data_str & "),3)"
    ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_UCL3", RefersToR1C1:="=" & avg_str & "+ roundup(3*stdev(" & data_str & "),3)"
相关问题
最新问题