我在网上发现了一个在线创建统计质量控制图表的宏。所以我有一个看起来像excel表的.Csv文件。我使用宏，所以我必须选择数据点。然后我必须选择标签，然后绘制它。
因此，我不想像我的宏那样计算所选数据的标准偏差，而是希望它从设定的标准差计算上限和下限。这是在单元格“F3”中。我尝试创建一个变体，其中“stddev = Range（”F3“）。value”但是当我将它包含在我的宏中时，数据被分散，右边的标签没有像以前那样显示出来。我将在代码中指出我认为问题所在的位置。
以下是创建质量控制图表的完整代码：
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
Dim stddev As Variant
On Error GoTo if_error_occured: 'GOTO THE END OF THE PROGRAM
stddev = Range("F3").Value
'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)"
'HERE THE LIMITS ARE SET AND THE ORIGINAL CODE IS SET IN THERE WHERE IT WORKS ON A SET OF DATA POINTS, HOWEVER WHEN I TRY TO CHANGE IT TO JUST "1*stddev,3" the data gets all scattered. I'M WONDERING WHY THE DATA IS BEING SCATTERED?
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 & "),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)"
在图表上格式化和创建线条的代码：
'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
答案 0 :(得分：0)
已编译但未经过测试：
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
Dim stddev As Variant
Dim wb As Workbook, sCht As String, i As Long
Set wb = ActiveWorkbook
'On Error GoTo if_error_occured: 'GOTO THE END OF THE PROGRAM
stddev = Range("F3").Value
'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 !"
Exit Sub 'not End!
ElseIf Not (check_if_numeric(data_values)) Then
MsgBox "Incorrect Input Data !"
Exit Sub 'not 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
MyNewSrs.Delete
Next MyNewSrs
Set MyNewSrs = Nothing
'IF WE HAVE THE LABEL RANGE
'ADD NEW SERIES
Set MyNewSrs = myChtObj.Chart.SeriesCollection.NewSeries
With MyNewSrs
.Name = "PLOT"
.Values = data_values
If got_label_range Then
.XValues = chart_labels.Value
End If
End With
'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
sCht = sCht
data_str = sCht & "_data_values"
avg_str = "roundup(average(" & sCht & "_data_values" & "),2)"
wb.Names.Add Name:=sCht & "_data_values", RefersToR1C1:=data_values
wb.Names.Add Name:=sCht & "_AVG", RefersToR1C1:="=" & avg_str & ""
For i = 1 To 3
wb.Names.Add Name:=sCht & "_LCL" & i, _
RefersToR1C1:="=" & avg_str & "- roundup(" & i & "*" & stddev & ",3)"
wb.Names.Add Name:=sCht & "_UCL" & i, _
RefersToR1C1:="=" & avg_str & "+ roundup(" & i & "*" & stddev & ",3)"
Next i
End Sub
Public Function GetRange(box_message As String) As Range
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, rv As Boolean
rv = True
For Each cel In rng.Cells
If Not (Application.WorksheetFunction.IsNumber(cel.Value)) Then
rv = False
Exit For
End If
Next cel
check_if_numeric = rv
End Function