|
|||||
このサンプルのMDBファイルは、こちら「X-R管理図のサンプル」からダウンロード出来ます。 このサンプルの「Ｘ−Ｒ管理図」というフォームを実行すると次のような画面が表示されます。  ACCESS(アクセス)によるX-R管理図の作り方は以下の流れで作成しています。 １．マスタ(管理限界係数)テーブルの作成 この係数を使用してX管理図、R管理図の値を計算しています。 (1)サンプルの各グループの平均値(X) (2)Xの上方管理限界(UCL(X)＝(Xの平均)＋A2×(Rの平均)) (3)Xの下方管理限界(LCL(X)＝(Xの平均)−A2×(Rの平均)) (4)サンプルの各グループの範囲(R) (5)Rの上方管理限界(UCL(R)＝D4×(Rの平均)） サンプル数 A2 D4
2 1.880 3.267
3 1.023 2.575
4 0.729 2.282
5 0.577 2.115
6 0.483 2.004
7 0.419 1.924
8 0.373 1.864
9 0.337 1.816
10 0.308 1.777
２．ワーク(平均X)テーブルの作成このテーブルはX管理図を表示する際のワークデータとして使用されます。 テーブル内の項目は次の通りです。 (1)各グループ番号 (2)各グループの平均X (3)Xの平均 (4)Xの上方管理限界UCL (5)Xの下方管理限界LCL ３．ワーク(範囲R)テーブルの作成 このテーブルはR管理図を表示する際のワークデータとして使用されます。 テーブル内の項目は次の通りです。 (1)各グループ番号 (2)各グループの範囲R (3)Rの平均 (4)Rの上方管理限界UCL ４．データ・テーブルの作成 このテーブルはX-R管理図を表示するための元データです。 あらかじめデータを入力して置く必要があります。 テーブル内の項目は次の通りです。 (1)データ番号（連番を入力します） (2)データ値（実際のデータを入力します） ５．X-R管理図フォームの作成 X-R管理図の表示に必要な次のコントロールを貼り付けます。 (1)サンプル数を入力するためのコンボボックス (2)X管理図を表示するための折れ線グラフ (3)R管理図を表示するための折れ線グラフ ６．ACCESS(アクセス)VBA(プログラム)の入力 フォーム表示時とサンプル数を変更した時の処理をプログラミングします。 ADOを使用してデータベースからデータを取得しています。
'-------------------------------------------------------------------------------
Option Explicit
Option Compare Database
Private Sub Form_Load()
DispXR サンプル数.Value
End Sub
Private Sub サンプル数_Change()
DispXR サンプル数.Value
X管理図.Requery
R管理図.Requery
End Sub
Private Sub DispXR(ByVal samp_num As Long)
Dim Rs1 As ADODB.Recordset: Set Rs1 = New ADODB.Recordset
Dim Rs2 As ADODB.Recordset: Set Rs2 = New ADODB.Recordset
Dim a2 As Double: a2 = 0
Dim d4 As Double: d4 = 0
Dim sql As String
' ワーク(平均X)内の全データ削除
sql = "DELETE FROM [ワーク(平均X)]"
Rs1.Open sql, CurrentProject.Connection
' ワーク(範囲R)内の全データ削除
sql = "DELETE FROM [ワーク(範囲R)]"
Rs1.Open sql, CurrentProject.Connection
' マスタ(管理限界係数)取得
sql = "SELECT * FROM [マスタ(管理限界係数)] WHERE [サンプル数]=" & samp_num
Rs1.Open sql, CurrentProject.Connection
If Rs1.EOF = False Then
a2 = Rs1.Fields(1)
d4 = Rs1.Fields(2)
End If
Rs1.Close
' データ読み込む(サンプル数毎にグループ分け)
sql = "SELECT * FROM [データ]"
Set Rs1 = New ADODB.Recordset
Rs1.Open sql, CurrentProject.Connection
Dim x As Double: x = 0
Dim r As Double: r = 0
Dim xt As Double: xt = 0
Dim rt As Double: rt = 0
Dim r1 As Double
Dim r2 As Double
Dim i As Long: i = 0
Dim g As Long: g = 0
Do While Rs1.EOF = False
' 各グループの初期設定
If (i Mod samp_num) = 0 Then
x = 0
r1 = 999999999#
r2 = -999999999#
End If
' 各グループの合計計算
x = x + Rs1.Fields(1)
' 各グループの最小計算
If r1 > Rs1.Fields(1) Then
r1 = Rs1.Fields(1)
End If
' 各グループの最大計算
If r2 < Rs1.Fields(1) Then
r2 = Rs1.Fields(1)
End If
i = i + 1
If (i Mod samp_num) = 0 Then
g = g + 1
' 各グループの平均計算
x = x / samp_num
r = r2 - r1
' 各グループの範囲計算
xt = xt + x
rt = rt + r
' ワーク(平均X)追加(各グループの平均)
sql = "INSERT INTO [ワーク(平均X)](" & _
"[各グループ番号]," & _
"[各グループの平均X]) VALUES(" & _
"" & Int(i / samp_num) & "," & _
"" & x & _
")"
Rs2.Open sql, CurrentProject.Connection
' ワーク(範囲R)追加(各グループの範囲)
sql = "INSERT INTO [ワーク(範囲R)](" & _
"[各グループ番号]," & _
"[各グループの範囲R]) VALUES(" & _
"" & Int(i / samp_num) & "," & _
"" & r & _
")"
Rs2.Open sql, CurrentProject.Connection
End If
' 次のデータへ
Rs1.MoveNext
Loop
Rs1.Close
' Xの平均計算、Rの平均計算
If g > 0 Then
xt = xt / g
rt = rt / g
End If
' ワーク(平均X)更新(平均、管理限界)
Dim x_ucl As Double: x_ucl = xt + (a2 * rt)
Dim x_lcl As Double: x_lcl = xt - (a2 * rt)
sql = "UPDATE [ワーク(平均X)] SET " & _
"[Xの平均]=" & xt & "," & _
"[Xの上方管理限界UCL]=" & x_ucl & "," & _
"[Xの下方管理限界LCL]=" & x_lcl
Rs2.Open sql, CurrentProject.Connection
' ワーク(範囲R)更新(平均、管理限界)
Dim r_ucl As Double: r_ucl = d4 * rt
sql = "UPDATE [ワーク(範囲R)] SET " & _
"[Rの平均]=" & rt & "," & _
"[Rの上方管理限界UCL]=" & r_ucl
Rs2.Open sql, CurrentProject.Connection
End Sub
'-------------------------------------------------------------------------------
|