ラベル 検索 の投稿を表示しています。 すべての投稿を表示
ラベル 検索 の投稿を表示しています。 すべての投稿を表示

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
変数一覧
ラベル: , , ,

VBA オートフィルタの件数表示



AutoFilterで抽出したデータ数をカウントする


VBAを使ってオートフィルタで抽出したデータ数をカウントする方法です。
また、表示されている最終行番号も取得します。

関数、メソッドなど
XlCellTypeの定数を使用します。
Range.SpecialCells(xlCellTypeVisible).Count
指定したセルの範囲（Range）に対して表示されているセル（xlCellTypeVisible）をカウントします。


サンプルコード
Sub autosu()
Dim r As Long '最終行用
Dim countdata As Long 'データ数カウント用

'最終行を取得
r = Cells(Rows.Count, 1).End(xlUp).Row

'B列が東証1部のものを抽出
Range("a1").AutoFilter Field:=2, Criteria1:="東証1部"

'表示されているデータ数を取得
countdata = Range(Cells(2, 1), Cells(r, 1)).SpecialCells(xlCellTypeVisible).Count

    MsgBox countdata

End Sub


解説
まずはテーブルにある最終行番号を取得し、変数rに格納します。
オートフィルタでデータ抽出後にテーブル範囲全体行に対して、表示されている行数をカウントします。

ただ、抽出されたデータ数が0の場合、

「実行時エラー'1004';
　該当するセルが見つかりません。」

というエラーが出てしまいます。
これを回避するために

Range.SpecialCells(xlCellTypeLastCell)

で、抽出されたデータの最終行を調べてから分岐させます。

Sub autosu2()
Dim r As Long '最終行用
Dim r1 As Long
Dim countdata As Long 'データ数カウント用

'最終行を取得
r = Cells(Rows.Count, 1).End(xlUp).Row

'B列が東証1部のものを抽出
Range("a1").AutoFilter Field:=2, Criteria1:="東証3部"

'表示されているデータの最終行を取得
r1 = Range("A1").SpecialCells(xlCellTypeLastCell).Row


If r1 = 1 Then
    countdata = 0
Else
    '表示されているデータ数を取得
    countdata = Range(Cells(2, 1), Cells(r, 1)).SpecialCells(xlCellTypeVisible).Count
End If


    MsgBox countdata

End Sub



関連・類似ページ
XlCellType列挙
値の入っているセルのみを選択
最終セルの取得
ラベル: , , ,

VBA セルの位置検索(WorksheetFunction.Match)




WorksheetFunction.Match(検査値,検査範囲,0)


検査範囲内でで検査値に合致する位置を返すメソッドです。
Findメソッドが遅く感じている部分がありましたがこちらに変更するとだいぶ早くなりました。


名前 説明 備考
Arg1 検査値 範囲内で検索する値
Arg2 検査範囲 検索する範囲
Arg3 検査方法 -1:検査値以上の最小値
0:検査値に完全一致する値
1:検査値以下の最大値

検査値方法Arg3は既定値は1ですが完全一致する値があればどれでも同じ結果になります。


Sub SampleMatch()
 Dim r As Long
 'ABCという検査値を"シートのA列"から探す
 r = WorksheetFunction.Match("ABC", Worksheets(1).Columns("A"), 0)
  
 MsgBox CelRow
End Sub
メッセージボックスに見つけた行数を返します。


検査値が検査範囲にない場合や検査値がブランク(="")の場合は
「worksheetfunctionクラスのmatchプロパティを取得できません」


と出るのでMatchメソッドの前に
On Error GoToや
On Error Resume Next
もしくは
If 検査値 <> "" Then　
などで回避するのが良さそうです。


参照・類似ページ
文字列検索[Find]メソッド

ラベル: ,