You are here:

# Excel/Stretching a set of data

Thomas Hunniford wrote at 2013-07-24 16:21:23
Here is a visual basic macro for excel that will interpolate your data.  It assumes that your data is in columns.  Select the area you want your data to fill (with the original data starting in the first row of the selected area).

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' RESAMPLE DATA IN A COLUMN STARTING AT y,x TO FILL h CELLS

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub resamplecolumn(y As Long, x As Long, h As Long)

'''''''''''''''''''''''

' CREATE THE VARIABLES

'''''''''''''''''''''''

Dim i As Long

Dim k As Long

Dim usz As Long

Dim u() As Double

Dim vsz As Long

Dim v() As Double

Dim y0, y1, y2, y3 As Double

Dim t As Double

Dim step As Double

'''''''''''''''''''''''''''

' INITIALISE THE VARIABLES

'''''''''''''''''''''''''''

usz = 0

vsz = h

'''''''''''''''''''''''''''

' WORK OUT HOW MANY CELLS

' CONTAIN NUMBERS

'''''''''''''''''''''''''''

Do While (Not (IsEmpty(Cells(y + usz, x).Value)))

usz = usz + 1

Loop

''''''''''''''''''''''''''''''

' IF THERE ARE NO NUMBERS

' THEN THERE IS NOTHING TO DO

''''''''''''''''''''''''''''''

If (usz <= 0 Or vsz <= 0) Then

Exit Sub

End If

'''''''''''''''''''''''''''

' CREATE DYNAMIC ARRAYS

'''''''''''''''''''''''''''

ReDim u(usz)

ReDim v(vsz)

''''''''''''''''''''''''''''''

' FILL U ARRAY

''''''''''''''''''''''''''''''

For i = 1 To usz

u(i) = Cells(y + i - 1, x).Value

Next i

''''''''''''''''''''''''''''''

' IF THERE IS ONE NUMBER THEN

' JUST FILL WITH THAT NUMBER

''''''''''''''''''''''''''''''

If (usz = 1) Then

For i = 1 To vsz

v(i) = u(1)

Next i

For i = 1 To vsz

Cells(y + i - 1, x).Value = v(i)

Next i

Exit Sub

End If

''''''''''''''''''''''''''''''

' IF THERE ARE TWO NUMBERS

' THEN DO LINEAR INTERPOLATION

''''''''''''''''''''''''''''''

If (usz = 2) Then

If (vsz = 1) Then

v(1) = (u(1) + u(2)) / 2

Else

For i = 1 To vsz

v(i) = u(1) + (i - 1) * (u(2) - u(1)) / (vsz - 1)

Next i

End If

For i = 1 To vsz

Cells(y + i - 1, x).Value = v(i)

Next i

If (usz > vsz) Then

For i = vsz + 1 To usz

Cells(y + i - 1, x).Value = ""

Next i

End If

Exit Sub

End If

''''''''''''''''''''''''''''''''''''

' IF THERE ARE 3 NUMBERS THEN

' PERFORM A QUADRATIC INTERPOLATION

''''''''''''''''''''''''''''''''''''

If (usz = 3) Then

If (vsz = 1) Then

v(1) = (u(1) + u(2) + u(3)) / 3

Else

For i = 1 To vsz

v(i) = (u(1) * (vsz + 1 - i - i) * (vsz - i) + 4 * u(2) * (i - 1) * (vsz - i) + u(3) * (i - 1) * (i + i - vsz - 1)) / ((vsz - 1) * (vsz - 1))

Next i

End If

For i = 1 To vsz

Cells(y + i - 1, x).Value = v(i)

Next i

If (usz > vsz) Then

For i = vsz + 1 To usz

Cells(y + i - 1, x).Value = ""

Next i

End If

Exit Sub

End If

''''''''''''''''''''''''''''''''''''

' IF THERE ARE MORE THAN 3 NUMBERS

' THEN PERFORM A CUBIC INTERPOLATION

''''''''''''''''''''''''''''''''''''

y0 = u(1)

y1 = u(2)

y2 = u(3)

y3 = u(4)

step = (usz - 1) / (vsz - 1)

i = 0

k = 0

Do While (i < vsz)

t = i * step          ' Calculate how current point in output array relates to input array

Do While (t >= k + 2)          ' Update y0, y1, y2 and y3 to be surrounding points

y0 = y1

y1 = y2

y2 = y3

If (k + 5 <= usz) Then

y3 = u(k + 5)

Else

y3 = y0 - 3 * y1 + 3 * y2 ' If gone off end then use a quadratic extrapolation

End If

k = k + 1

Loop

t = t - k          ' Adjust t value to be relative to first point ... now to do a simple calculation ...

v(i + 1) = ((-y0 + 3 * y1 - 3 * y2 + y3) * t * t * t + (6 * y0 - 15 * y1 + 12 * y2 - 3 * y3) * t * t + (-11 * y0 + 18 * y1 - 9 * y2 + 2 * y3) * t + (6 * y0)) / 6

i = i + 1

Loop

For i = 1 To vsz

Cells(y + i - 1, x).Value = v(i)

Next i

If (usz > vsz) Then

For i = vsz + 1 To usz

Cells(y + i - 1, x).Value = ""

Next i

End If

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' RESAMPLE DATA IN CELLS TO FIT LARGER AREA

' Each cell in the top left corner of select area must contain a number

' Interpolated data is then used to fill the entire area

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub resample()

Dim ys As Long

Dim xs As Long

Dim hs As Long

Dim ws As Long

Dim ix As Long

ys = Selection.Cells(1, 1).Row          ' Selection start y value

xs = Selection.Cells(1, 1).Column         ' Selection start x value

hs = Selection.Rows.Count()          ' Selection height

ws = Selection.Columns.Count()          ' Selection width

For ix = 1 To ws

Call resamplecolumn(ys, xs + ix - 1, hs)

Next ix

End Sub

This topic answers questions related to Microsoft Excel spreadsheet (or workbook) stand-alone or Mircrosoft Office Excel including Excel 2003, Excel 2007, Office 2000, and Office XP. You can get Excel help on Excel formulas(or functions), Excell macros, charting in Excel, advanced features, and the general use of Excel. This does not provide a general Excel tutorial nor the basics of using a spreadsheet. It provides specific answers to using Microsoft Excel only. If you do not see your Excel question answered in this area then please ask an Excel question here

#### Bill Hermanson

##### Expertise

Please tell me WHICH EXCEL VERSION you are using!

DO NOT ASK ME me about Macros or VBA.

Please read my "instructions to questioners" in my full profile [use View Profile, at right], to help you write a question that I can understand, without having to ask you what you mean.

If your question contains any of the words THIS, IT, THAT, THOSE, or THEY, I likely won't understand IT. Please rewrite!

My Expertise: I am an expert at data manipulation, the use of incredibly complex logical statements, databases, combining tables and extracting data, all the LOGICAL, LOOKUP & REFERENCE functions, dynamic ranges, creating professional appearing spreadsheets, complex functions, integrated charts and visual displays, user interfaces.... I can make Excel do anything!

But PLEASE... NO MACRO or VBA QUESTIONS!

##### Experience

25 years development of complex spreadsheets for personal and professional use. I've developed hundreds (or thousands!) of spreadsheets in all fields, from complex engineering calculations to game scoring, financial analysis, scheduling, cost-of-doing-business, and analysis of home energy use. I even used Excel to assist in design of the flight computers presently on board the Hubble Space Telescope (1984-1991)

Education/Credentials
BSEE Electrical Engineering, CU Boulder CO USA
Use of spreadsheets since 1982
Boulder Valley School District, Life Long Learning, Instructor
Owner & Operator of Excel Expert, LLC