【Excel VBA】3変数関数の線形補間を行うExcelマクロ

Function Interpolation3D(ByVal x As Double, ByVal y As Double, ByVal z As Double, ParamArray ranges() As Variant) As Double

    Dim z1, z2 As Double
    Dim z1_index, z2_index As Long
    Dim nz As Long
    Dim f1, f2, f As Double
    
    'Get reference values of z and its index
    nz = (UBound(ranges, 1) + 1) / 4 - 1
    For i = 0 To nz - 1
        If ranges(4 * i + 2) <= z And ranges(4 * (i + 1) + 2) >= z Then
            z1_index = i
            z2_index = i + 1
            z1 = ranges(4 * z1_index + 2)
            z2 = ranges(4 * z2_index + 2)
        End If
    Next i
    'Constant value extrapolation in out of range of known values
    If z <= ranges(4 * 0 + 2) Then z1_index = 0
    If z >= ranges(4 * nz + 2) Then z1_index = nz - 1
    
    'Get interpolated values against x and y
    f1 = Interpolation2D(x, y, ranges(4 * z1_index + 0), ranges(4 * z1_index + 1), ranges(4 * z1_index + 3))
    f2 = Interpolation2D(x, y, ranges(4 * z2_index + 0), ranges(4 * z2_index + 1), ranges(4 * z2_index + 3))
    
    'Get interpolated values against z
    If z <= ranges(2) Then
        f = f1
    ElseIf z >= ranges(4 * nz + 2) Then
        f = f2
    Else
        f = f1 + (f2 - f1) / (z2 - z1) * (z - z1)
    End If

    Interpolation3D = f

End Function

Function Interpolation2D(ByVal x As Double, ByVal y As Double, ByRef x_range As Variant, ByRef y_range As Variant, ByRef f_range As Variant) As Double
    
    '1:lower, 2:upper
    Dim y1, y2 As Double 'reference value both sides of y
    Dim y1_index, y2_index As Long 'reference value index both sides of y
    Dim f1, f2, f As Double 'interpolated value
    Dim tmp() As Variant
    Dim i As Long
    
    ' Get reference value index of y
    With WorksheetFunction
    
        If y < .Min(y_range) Then y = .Min(y_range)     'Constant value extrapolation in range under lower limit
        y1_index = .Match(y, y_range, 1)
        y2_index = .Min(y1_index + 1, y_range.Count)    'Constant value extrapolation in range over the upper limit
        
    End With 'if x or y out of known value range, 1 and 2 indexes become same value
    
    ' Get reference values of y
    y1 = y_range(y1_index)
    y2 = y_range(y2_index)
    
    ' Get reference values of f
    f1 = Interpolation1D(x, x_range, f_range(y1_index))
    f2 = Interpolation1D(x, x_range, f_range(y2_index))

    'Get interpolated values against y
    If y2 <> y1 Then
        f = f1 + (f2 - f1) * (y - y1) / (y2 - y1)
    Else
        f = f1
    End If

    Interpolation2D = f    

End Function

Function Interpolation1D(ByVal x As Double, ByRef x_range As Variant, ByRef f_range As Variant) As Double
    
    '1:lower, 2:upper
    Dim x1, x2 As Double 'reference value both sides of x
    Dim x1_index, x2_index As Long 'reference value index both sides of x
    Dim f, f1, f2 As Double 'interpolated value
    Dim tmp() As Variant
    Dim i As Long
    
    ' Get reference value index of x
    With WorksheetFunction
        
        If x < .Min(x_range) Then x = .Min(x_range)     'Constant value extrapolation in range under lower limit
        x1_index = .Match(x, x_range, 1)
        x2_index = .Min(x1_index + 1, x_range.Count)    'Constant value extrapolation in range over the upper limit
        
    End With 'if x or y out of known value range, 1 and 2 indexes become same value
    
    ' Get reference values of x
    x1 = x_range(x1_index)
    x2 = x_range(x2_index)
    
    ' Get reference values of f
    f1 = f_range(x1_index)
    f2 = f_range(x2_index)
    
    'Get interpolated values against x
    If x2 <> x1 Then
        f = f1 + (f2 - f1) * (x - x1) / (x2 - x1)
    Else
        f = f1
    End If

    Interpolation1D = f

End Function