データ取得時にサンプリング区間が細かすぎる場合、データ数が膨大になって処理や解析に時間を要することがあると思う。
今回は膨大になったデータ数を削減するために、データを間引くマクロを作ってみた。
サンプル
今回使うサンプルは下記ボタンから入手可能である。
圧縮ファイルの中には下記3つのファイルが格納されている。
・exp10_comp.xlsm
・data10-1.dat
・data10-2.dat
まず「exp10_comp.xlsm」を開くと、次のような画面が表示される。
「データ取込および間引き」ボタンをクリックすると[参照]ダイアログが表示されるので、同ファイル内に格納されていた「data10-1.dat」と「data10-2.dat」を選択し「OK」をクリックする。
すると、「exp10_comp.xlsm」にdatファイルが取り込まれ、その後自動でデータの間引きが実行され、結果が出力されたシートが追加される。
追加されたシートを開くと次のようになっている。
左側が生データで、右側の黄色くセルが塗り潰されている部分が間引き後のデータである。
両者を比較するとわかるように、今回のマクロではデータのサンプリング区間が1になるように他のデータを間引いている。
コード詳説
「exp10_comp.xlsm」には2つのマクロが保存されている。
本記事ではデータの間引きに関するマクロの解説を実施し、その他のマクロについては以前書いた記事を参照されたい。
データ取込および間引き
マクロの中身は下記のようになっている。
Sub データ取込および間引き()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim FD As FileDialog
Dim C As Long
Dim R As Long
Dim D As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim m As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set FD = Application.FileDialog(msoFileDialogFilePicker)
FD.AllowMultiSelect = True
j = Worksheets.Count
If FD.Show = True Then
For i = 1 To FD.SelectedItems.Count
Workbooks.OpenText Filename:=FD.SelectedItems(i)
Cells.Select
Selection.Copy
ActiveWindow.Close
Sheets.Add After:=Worksheets(j)
With Worksheets(j + 1)
.Name = Dir(FD.SelectedItems(i))
.Paste
End With
C = Worksheets(j + 1).Range("A1").End(xlToRight).Column
R = Worksheets(j + 1).Range("A1").End(xlDown).Row
For l = 1 To C
With Worksheets(j + 1).Cells(1, C + 1 + l)
.Value = Worksheets(j + 1).Cells(1, l).Value
.Interior.ColorIndex = 6
End With
Next
m = 2
For l = 3 To R
D = Fix(Worksheets(j + 1).Cells(l, 1).Value) - Fix(Worksheets(j + 1).Cells(l - 1, 1).Value)
If D = 1 Or (Int(Worksheets(j + 1).Cells(l, 1).Value) = 0 And Int(Worksheets(j + 1).Cells(l - 1, 1).Value) = -1) Then
If Worksheets(j + 1).Cells(l, 1).Value < 0 And Worksheets(j + 1).Cells(l - 1, 1).Value < 0 Then
For k = 1 To C
With Worksheets(j + 1).Cells(m, C + 1 + k)
.Value = Worksheets(j + 1).Cells(l - 1, k).Value
.Interior.ColorIndex = 6
End With
Next
m = m + 1
ElseIf (Int(Worksheets(j + 1).Cells(l, 1).Value) = 0 And Int(Worksheets(j + 1).Cells(l - 1, 1).Value) = -1) Or (Worksheets(j + 1).Cells(l, 1).Value > 0 And Worksheets(j + 1).Cells(l - 1, 1).Value > 0) Then
For k = 1 To C
With Worksheets(j + 1).Cells(m, C + 1 + k)
.Value = Worksheets(j + 1).Cells(l, k).Value
.Interior.ColorIndex = 6
End With
Next
m = m + 1
End If
End If
Next
With Worksheets(j + 1)
.Hyperlinks.Add Anchor:=Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column + 1), _
Address:="", _
SubAddress:="'" & Worksheets(1).Name & "'" & "!A1", _
TextToDisplay:=Worksheets(1).Name
.Range("A1").Select
End With
With Worksheets(1)
.Activate
.Hyperlinks.Add Anchor:=Cells(j + 7, 2), _
Address:="", _
SubAddress:="'" & Worksheets(j + 1).Name & "'" & "!A1", _
TextToDisplay:=Worksheets(j + 1).Name
.Cells(j + 7, 2).Borders.LineStyle = xlContinuous
End With
j = j + 1
Next
End If
Worksheets(1).Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub太字の部分がデータを間引きするコードである
その他のコードは以前に下記記事にて解説したデータの取込マクロと同じコードであるため、本記事での解説は省略する。
前回と被る部分については下記記事を参照されたい。
まず
C = Worksheets(j + 1).Range("A1").End(xlToRight).Column
R = Worksheets(j + 1).Range("A1").End(xlDown).Rowで取り込んだデータ(生データ)の行数と列数を把握し、行数をR、列数をCに代入する。
次に
For l = 1 To C
With Worksheets(j + 1).Cells(1, C + 1 + l)
.Value = Worksheets(j + 1).Cells(1, l).Value
.Interior.ColorIndex = 6
End With
Nextで生データの各列の見出し(ヘッダー)を、生データの右隣りにコピペし、セルを黄色に塗りつぶしている。
Worksheets(i).Range(“A1”).Interior.ColorIndex = x
⇒ i番目のシートのA1セルを色番号(ColorIndex)xで指定された色で塗りつぶす。
下記、代表的な色とナンバーの対応表を示す。
| ColorIndex | 色 |
|---|---|
| 1 | 黒 |
| 2 | 白 |
| 3 | 赤 |
| 4 | 黄緑 |
| 5 | 青 |
| 6 | 黄 |
| 7 | 桃 |
| 8 | 水 |
| 9 | 濃い赤 |
| 10 | 緑 |
| 11 | 濃い青 |
| 12 | 濃い黄 |
| 13 | 紫 |
| 14 | 青緑 |
次に
m = 2で間引き後データの行数の初期値を指定し、For l = 3 To R ～ Nextで生データの各行を上から順に調べ、X値(横軸)の整数値が変わる部分を探し出し、それを抜き出して右隣にデータをコピペする。
ここでFor l = 3 To R ～ Nextの中身を見ていく。
D = Fix(Worksheets(j + 1).Cells(l, 1).Value) - Fix(Worksheets(j + 1).Cells(l - 1, 1).Value)は、生データの隣り合う行同士でX値の整数部分の差を計算している。
Fix(x)：値xの整数値を返す。例 -5.8 ⇒ -5
Int(x)：値xの整数値を返す。ただしx<では、xの整数値に-1した値を返す。例 -5.8 ⇒ -6
整数値が変わらない部分ではD=0となるが、整数部分が変わる部分ではD=1となるため、これをトリガーにしてif文を利用してデータを抜き出す。
If D = 1 Or (Int(Worksheets(j + 1).Cells(l, 1).Value) = 0 And Int(Worksheets(j + 1).Cells(l - 1, 1).Value) = -1) ThenD=1のほかに、Int(Worksheets(j + 1).Cells(l, 1).Value) = 0 And Int(Worksheets(j + 1).Cells(l – 1, 1).Value) = -1という条件があるが、これはFixでは-1<x<1の範囲にある値は全て0を返してしまうため、-1⇒0への変化を発見できないことへの対策である。
さらに、このif文の中身もif文になっているが、これはX値の符号で場合分けをしている。
まず隣り合う行のX値がともに負である場合、
If Worksheets(j + 1).Cells(l, 1).Value < 0 And Worksheets(j + 1).Cells(l - 1, 1).Value < 0 Then
For k = 1 To C
With Worksheets(j + 1).Cells(m, C + 1 + k)
.Value = Worksheets(j + 1).Cells(l - 1, k).Value
.Interior.ColorIndex = 6
End With
Next
m = m + 1となる。
kには抜き出すデータの列数が代入される。
kでループを回し、生データのl-1番目のデータを右隣にコピペする。
またコピペが終了したら、mに1を足し、次の行にデータをコピペできるようにする。
次にX値の整数値が-1⇒0へ変化する場合と、隣り合う行のX値がともに正である場合は
ElseIf (Int(Worksheets(j + 1).Cells(l, 1).Value) = 0 And Int(Worksheets(j + 1).Cells(l - 1, 1).Value) = -1) Or (Worksheets(j + 1).Cells(l, 1).Value > 0 And Worksheets(j + 1).Cells(l - 1, 1).Value > 0) Then
For k = 1 To C
With Worksheets(j + 1).Cells(m, C + 1 + k)
.Value = Worksheets(j + 1).Cells(l, k).Value
.Interior.ColorIndex = 6
End With
Next
m = m + 1となる。
コードの種類は先ほどと同じだが、コピペする生データがl番目である部分で異なっている。
後はこの処理を生データの行数分実施すれば、右隣に間引き後のデータが残る。
データファイル転記のシートの削除
下記記事を参照。
終わりに
本音を言うと、抜き出す間隔を可変にしたり、グラフを描画して比較できるようにしたりと他にも追加したい機能があったのだが、本来の目的の「データの間引き」が正常に機能しているので今回は妥協した。
どこかの機会でこのマクロをいじって、もう少し汎用性のあるものに作り変えたい。
END
コメント