Surface charts with empty cells

[Sortawired]

Is there a way to have a surface chart, in 3D or 2D,
interpolate empty cells. I've tried the interpolate macro
with no success, as all interpolation functions I've found
so far seem to only work on a single series at once.

 

[Tushar Mehta]

Maybe you are having a hard time finding any interpolation routines for

1D because there aren't that many available.

Also, before you start using the suggestion below, do remember that an
XL surface chart is actually based on 'category' axes, and the x- and
y-axes are not true numeric scales.

For a crude function that uses straight-line / flat-surface
interpolation, use the code below. The first two functions are support
functions, the 3rd does the interpolation, and the last Sub is for a
simple test.

To use this in an XL worksheet, suppose you have a sheet set up with
values in B4:E7 as:

x\y 0 1 2
0 0 2
1
2 2 4

Plot B4:E7 as a surface plot.

To fill in the values for the missing data points, in D5 (below the 1
and to the right of the zero), enter
=Interpolate2D(($C$5,$E$5,$C$7,$E$7),($B$5,$B$7),($C$4,$E$4),$B5,D$4)
Copy D5 to D67. Copy D6 to C6, E6.

The code below goes into a standard module.

Option Explicit
Option Base 1
Function CellAreaDecode(x, ByVal i As Long) As Range
Dim AreaI As Long
For AreaI = 1 To x.Areas.Count
If i <= x.Areas(AreaI).Cells.Count Then
Set CellAreaDecode = x.Areas(AreaI).Cells(i)
Exit Function
Else
i = i - x.Areas(AreaI).Cells.Count
End If
Next AreaI
End Function
Sub MapIn(InVal, ByRef Where, ByVal HowMany)
Dim i As Integer
If Not (TypeOf InVal Is Range) Then
Where = InVal
ElseIf HowMany = 1 Then
Where = InVal.Cells(1).Value
Else
ReDim Where(1 To HowMany)
For i = 1 To HowMany
Where(i) = CellAreaDecode(InVal, i).Value
Next i
End If
End Sub
Function Interpolate2D(InF, InX, InY, InX1, InY1)
'X contains two values, x0 and x1 _
Y contains two values, y0 and y1 _
F contains 4 values, defined at (x0,y0), (x0,y2), _
(x2,y0), (x2,y2) _
x1 and y1 define the point at which the value of _
the function is required
'tests to ensure x0<x1<x2 and 'y0<y1<y1 needed
Dim F, x, Y, _
X1 As Double, Y1 As Double
Dim NoXvals(1 To 2)
MapIn InF, F, 4
MapIn InX, x, 2
MapIn InY, Y, 2
MapIn InX1, X1, 1
MapIn InY1, Y1, 1
NoXvals(1) = (F(3) - F(1)) / (x(2) - x(1)) * (X1 - x(1)) + F(1)
NoXvals(2) = (F(4) - F(2)) / (x(2) - x(1)) * (X1 - x(1)) + F(2)
Interpolate2D = _
(NoXvals(2) - NoXvals(1)) / (Y(2) - Y(1)) * (Y1 - Y(1)) _
+ NoXvals(1)
End Function

Sub testIt()
MsgBox Interpolate2D(Array(0, 2, 2, 4), Array(0, 2), _
Array(0, 2), 1, 1)
End Sub


--
Regards,

Tushar Mehta, MS MVP -- Excel
www.tushar-mehta.com
Excel, PowerPoint, and VBA add-ins, tutorials
Custom MS Office productivity solutions