0
我在線發現了一個可創建統計質量控制圖表的宏。所以我有一個.csv文件，看起來像一張excel表格。我使用宏，所以我必須選擇數據點。然後我必須選擇標籤，然後繪製標籤。我的統計質量控制圖表VB代碼中的錯誤
我的問題是UL2 =（上限，2 *標準偏差）和LL2 =（下限，2 *標準偏差）的錯誤條根本沒有顯示出來。所有其他錯誤欄顯示。如平均值，UL（上限）和LL（下限）以及UL3和LL3，但不是UL2和LL2。
此外，數據點不是沿着它們應該出現的平均線，它們也被移位。
我使用的示例表顯示了他們，但這是在一個常規的Excel文件。之所以將它作爲.CSV文件存在，是因爲我使用另一個宏來提取原始數據，並將其粘貼到新的.csv文件中。我認爲這是原因，但我不是100％肯定的。我想知道你們是否可以幫助我。我對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
這是怎麼看起來像當我繪製。即使在那裏UL2和LL2的錯誤欄也不存在。
基於圖片，他們不是黑色的虛線嗎？雖然沒有看到UCL1和LCL1。 UCL1 = UCL2和LCL1 = LCL2？可能是四捨五入問題。 – JJFord3 2014-12-03 21:11:37
對於遲到的回覆@ JJFord3非常抱歉，圖片中沒有錯誤沒有UCL2和LCL2的錯誤欄，文本剛好覆蓋在UCL 1和LCL 1的頂部。並且等待所以您說因爲數字未被舍入正確，這就是爲什麼它搞砸了？那個怎麼樣？ – adit123 2014-12-04 14:18:37