【Excelマクロ】データを自動で間引いて整形するマクロ

Excelマクロ

 データ取得時にサンプリング区間が細かすぎる場合、データ数が膨大になって処理や解析に時間を要することがあると思う。

 今回は膨大になったデータ数を削減するために、データを間引くマクロを作ってみた。

Microsoft Excel 2019の利用を想定しています。

サンプル

 今回使うサンプルは下記ボタンから入手可能である。

 

 圧縮ファイルの中には下記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) Then

 D=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

コメント

タイトルとURLをコピーしました