You are here:

Excel/Stretching a set of data

Advertisement


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  


About Excel
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

Excel

All Answers


Answers by Expert:


Ask Experts

Volunteer


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

©2016 About.com. All rights reserved.