【EXCEL VBA】飛び飛びの値の、間の数値を補完するマクロ

このページで紹介する内容
コードの紹介
Rows.Countで使用しているセルの一番下の行番号を取得
1. X2の値とX1の値を比較して、間の数値を計算
  1. Do While ・・・Loop関数で計算したい数値の場所を特定
まとめ
1. 線形補完マクロ

このページで紹介する内容

このページで紹介するマクロは「記録したデータの中間の値を、数値として自動で出したい！」という場面で使えます。

　具体例でいうと、下の図のX1（Ｂ列）-Y1（Ｃ列）のデータから、好きな値でX2（Ｄ列）を設定して、そのX2に対してY2（Ｅ列）の値を自動で算出してくれます。

＜メリット＞
エクセルで、記録したデータの中間の値を計算で求める作業の負担を軽減してくれます。

＜注意点＞
エクセルの「開発」タブを有効化し、VBAのコードを貼り付ける作業が必要です。

コードの紹介

VBAの標準モジュールに、以下のコードを貼り付ければ完了です。

Sub 線形補完マクロ()

Dim countR1 As Long
Dim countR2 As Long
Dim num1 As Long
Dim num2 As Long
Dim x1(1000) As Single
Dim y1(1000) As Single
Dim x2(1000) As Single
Dim y2(1000) As Single
Dim K(1000) As Single

countR1 = Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row
countR2 = Sheets(1).Cells(Rows.Count, 4).End(xlUp).Row
num1 = countR1 - 2
num2 = countR2 - 2
x1(0) = Sheets(1).Cells(3, 2).Value
y1(0) = Sheets(1).Cells(3, 3).Value
x2(0) = Sheets(1).Cells(3, 4).Value
y2(0) = 0

For i = 1 To num1
    x1(i) = Sheets(1).Cells(2 + i, 2).Value
    y1(i) = Sheets(1).Cells(2 + i, 3).Value
Next i

For j = 1 To num2
    x2(j) = Sheets(1).Cells(2 + j, 4).Value
      i = 1
      Do While x1(i - 1) < x2(j)
        If (x1(i) - x1(i - 1)) <= 0 Then
         K(j) = 0
        Else
         K(j) = (y1(i) - y1(i - 1)) / (x1(i) - x1(i - 1))
        End If
         y2(j) = K(j) * (x2(j) - x1(i - 1)) + y1(i - 1)
         Sheets(1).Cells(2 + j, 5) = y2(j)
      i = i + 1
      Loop
Next j

End Sub

　下のグラフは、X1-Y1のグラフとX2-Y2のグラフを重ねたものです。青い丸が元々のデータ（X1-Y1）です。青い丸の間の数値を計算したものが、赤い丸のデータ（X2-Y2）になります。

Rows.Countで使用しているセルの一番下の行番号を取得

　もともとあったデータX1とY1、それぞれのデータの数を調べるために、Rows.Countコマンドを使います。

　ここで、それぞれのデータは縦に並んでいることを前提とします。（もし、横に並んでいるデータを立てに並び替えたい場合は、こちらのページを参考にして下さい。）

countR1 = Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row
countR2 = Sheets(1).Cells(Rows.Count, 4).End(xlUp).Row
num1 = countR1 - 2
num2 = countR2 - 2

X2の値とX1の値を比較して、間の数値を計算

　飛び飛びの値の間の数値を計算する時には、線形（Xに対するYの変化量が一定）と考えると分かりやすいです。もともとあるデータの間毎にXとYの変化量を出すことで、間の数値を計算します。

For i = 1 To num1
    x1(i) = Sheets(1).Cells(2 + i, 2).Value
    y1(i) = Sheets(1).Cells(2 + i, 3).Value
Next i

For j = 1 To num2
    x2(j) = Sheets(1).Cells(2 + j, 4).Value
      i = 1
      Do While x1(i - 1) < x2(j)
        If (x1(i) - x1(i - 1)) <= 0 Then
         K(j) = 0
        Else
         K(j) = (y1(i) - y1(i - 1)) / (x1(i) - x1(i - 1))
        End If
         y2(j) = K(j) * (x2(j) - x1(i - 1)) + y1(i - 1)
         Sheets(1).Cells(2 + j, 5) = y2(j)
      i = i + 1
      Loop
Next j