VBA 外れ値の検定



外れ値の抽出


VBAを使って任意のデータから外れ値をの検定をします。
今回は外れ値を見つけたらセルの背景色を変え、別のデータテーブルを作成します。
外れ値検出の方法はスミルノフ・グラブス検定を使用します。


サンプルデータ

商品 1月 2月 3月 4月 5月 6月 7月 8月 9月 10月 11月 12月
商品1 24 31 169 58 93 48 83 34 22 20 8 26
商品2 54 79 251 73 55 71 64 54 44 65 41 101
商品3 72 44 189 147 47 34 84 79 50 78 25 422
商品4 114 49 158 182 122 144 154 66 113 161 56 142
商品5 65 19 71 54 80 121 154 21 59 15 62 17
商品6 60 30 107 500 158 -19 134 104 136 600 107 105
商品7 159 200 166 107 142 104 172 15 34 100 149 127
商品8 378 87 161 350 100 74 443 75 41 148 165 79
商品9 281 402 377 375 209 152 446 62 103 105 184 85
商品10 15 139 147 27 18 46 133 78 19 48 57 122
商品11 110 92 68 95 41 96 778 55 51 48 57 64
商品12 72 113 167 84 43 36 120 86 231 77 205 203
商品13 98 380 167 244 22 24 179 34 32 217 532 303
商品14 12 24 263 96 72 36 99 23 75 32 31 27
商品15 8 71 169 15 32 72 40 31 88 34 39 138
商品16 27 6 40 11 116 20 26 74 9 3 47 37
商品17 -2 12 46 54 5 163 116 -7 449 23 54 37
商品18 690 1122 1560 1108 1278 658 1088 984 1037 1357 1578 1241
商品19 952 1186 2190 2116 2262 1580 1259 1574 1814 1443 2 1408
商品20 97 327 285 284 323 34 157 90 251 134 77 146

サンプルデータは上記のような行に商品別、列に月が12か月分展開されているテーブルを使用します。
サンプルデータ

また事前の準備として同ファイルの別シートに「有意点」というシートを追加し下記のテーブルを作成しています。
（サンプルデータにはデータあります。）
検定の有意点α（片側）
　n　 0.1 0.05 0.025 0.01
3 1.148 1.153 1.154 1.155
4 1.425 1.462 1.481 1.493
5 1.602 1.671 1.715 1.749
6 1.729 1.822 1.887 1.944
7 1.828 1.938 2.02 2.097
8 1.909 2.032 2.127 2.221
9 1.977 2.11 2.215 2.323
10 2.036 2.176 2.29 2.41
11 2.088 2.234 2.355 2.484
12 2.134 2.285 2.412 2.549
13 2.176 2.331 2.462 2.607
14 2.213 2.372 2.507 2.658
15 2.248 2.409 2.548 2.705
16 2.279 2.443 2.586 2.747
17 2.309 2.475 2.62 2.785
18 2.336 2.504 2.652 2.821
19 2.361 2.531 2.681 2.853
20 2.385 2.557 2.708 2.884
22 2.428 2.603 2.758 2.939
24 2.467 2.644 2.802 2.987
26 2.502 2.681 2.841 3.029
28 2.534 2.714 2.876 3.068
30 2.563 2.745 2.908 3.103
35 2.627 2.811 2.978 3.178
40 2.68 2.867 3.036 3.239
50 2.767 2.956 3.128 3.337
60 2.84 3.03 3.2 3.41
80 2.94 3.13 3.31 3.52
100 3.02 3.21 3.38 3.6
150 3.15 3.34 3.52 3.73
200 3.24 3.43 3.6 3.82
300 3.36 3.55 3.72 3.94
400 3.45 3.63 3.8 4.02
500 3.51 3.69 3.86 4.07
1000 3.7 3.87 4.04 4.25

コード
Sub sumigra()

Dim r As Long, i As Long, j As Long, c As Long, n As Long
Dim yuiten As Double, ave As Double, stdev As Double, atai As Double
Dim yuisuijun As Double
Dim wsYui As Worksheet, wsKen As Worksheet
Dim WF As Object

Set WF = WorksheetFunction


Set wsKen = Worksheets("検査")
Set wsYui = Worksheets("有意点")

With wsKen
    '検査シートの有意水準を取得
    yuisuijun = .Cells(2, 1)
    
    '対象アイテム数
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    
    '棄却後データ用
    .Range(.Cells(4, 2), .Cells(r, 13)).Copy Destination:=.Cells(4, 15)
    
    For i = 5 To r
        n = 12 '今回の標本数(=月数)
        '有意点をwsYuiから探す
        With wsYui
            yuiten = WF.Index(.Range(.Cells(2, 1), .Cells(37, 5)), _
                        WF.Match(n, .Range(.Cells(2, 1), .Cells(37, 1)), 0), _
                        WF.Match(yuisuijun, .Range(.Cells(2, 1), .Cells(2, 5)), 0))
        End With
            
        ave = WF.Average(.Range(.Cells(i, 2), .Cells(i, 13)))
        
            If ave = 0 Then GoTo nodata
        
        stdev = WF.stdev(.Range(.Cells(i, 2), .Cells(i, 13)))

        For j = 2 To 13
            If .Cells(i, j + 13) = "" Then GoTo skip0
            'コピー先で処理する(+13)
            atai = Abs(.Cells(i, j + 13) - ave) / stdev
             
            If atai > yuiten Then
                .Cells(i, j).Interior.Color = RGB(180, 190, 240)
                .Cells(i, j + 13) = ""
                    '平均値再計算
                    ave = WF.Average(.Range(.Cells(i, 15), .Cells(i, 26)))
                    If ave = 0 Then GoTo nodata
                    stdev = WF.stdev(.Range(.Cells(i, 15), .Cells(i, 26)))
                    
                    'nが減るので再び
                    n = n - 1
                    '有意点をwsYuiから探す
                    With wsYui
                        yuiten = WF.Index(.Range(.Cells(2, 1), .Cells(37, 5)), _
                                    WF.Match(n, .Range(.Cells(2, 1), .Cells(37, 1)), 0), _
                                    WF.Match(yuisuijun, .Range(.Cells(2, 1), .Cells(2, 5)), 0))
                    End With
                    
                    '再び検定する
                    j = 1
                    
                    
            End If
        
skip0:
        Next j
        
nodata:
    
    Next i

End With


End Sub


実行すると



が



のようになります。

解説
検定で外れ値が検出されるたら、再び外れ値を除いたデータで検定をしています。
セル(2,1)のの有意水準を変えると有意点が変わります
（有意水準は0.01,0.25,0.5,0.1の4つどれか）

列数を増やしたり減らしたりでコードの値も変更しなければいけないです。

関連・類似ページ
最終セルの取得
セルのコピー
WorksheetFunction.Match
変数一覧
ラベル: , , ,