By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
425,830 Members | 682 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 425,830 IT Pros & Developers. It's quick & easy.

Interpolating data between two occurrences to work out individual date values

P: 5
Hi,

I’ve got a googly on my end.

I’m aiming to create a function or procedure that would take the difference between ‘a’ and ‘b' (i.e. ‘x’) where ‘a’ and ‘b’ are spaced ‘y’ cells apart (‘y’ could be 4,5,6 etc.), dividing ‘x’ by ‘y’ to get ‘z’, and then inputting ‘z’ in the previous ‘y’ cells plus in into cell ‘b’.

Hope this makes sense but if not, I have attached a sample workbook.

As always – assistance is much appreciated.

Thanks.
Attached Files
File Type: xlsx Test_Interpolation.xlsx (18.2 KB, 291 views)
Apr 2 '12 #1

✓ answered by Mihail

This code solve your problem.
Note that the code will not work if you change the data position in sheet.
If you do that you must change the constants values.

In attached workbooks (.xls and .xlsm) go to Sheet2 and press Adjust button to see the results.
The code is also in Sheet2 .

Expand|Select|Wrap|Line Numbers
  1. Option Explicit
  2. Const Cd As Long = 2 ' "Date" column (B)
  3. Const Cr As Long = 4 ' "Returns" column (D)
  4. '    Const Cr As Long = Cd + 2 'This is declared relative to Cd
  5. Const Ca As Long = 5 ' "Adjust" column (E)
  6. '    Const Ca As Long = Cd + 3 'This is declared relative to Cd
  7. '    Const Ca As Long = Cr + 1 'This is declared relative to Cr
  8. Const FirstRow As Long = 5 ' First row with data in your table
  9.  
  10. Dim Msg As VbMsgBoxResult 'Working variable
  11.  
  12. Private Sub cmdStartAdjust_Click()
  13.  
  14. Dim Rd As Long 'Row in "Date" column
  15. Dim Rr As Long 'Row in "Returns" column
  16. Dim Ra As Long 'Row in "Adjusted" column
  17.  
  18. Dim FirstPercent As Double, SecondPercent As Double, AdjustedPercent As Double
  19. Dim nDays As Long 'Number of days for adjustement
  20.  
  21.     Rd = FirstRow
  22.     Do
  23.         FirstPercent = Cells(Rd, Cr)
  24.         'Find the SecondPercent and number of days
  25.         nDays = 1
  26.         Rr = Rd + 1
  27.         Do Until Not IsEmpty(Cells(Rr, Cr))
  28.             Rr = Rr + 1
  29.             nDays = nDays + 1
  30.             If IsEmpty(Cells(Rr, Cd)) Then
  31.                 'The last date has not a "Returns" value
  32.                 Msg = MsgBox("No end for ""Returns""", vbCritical)
  33. Exit Sub
  34.             End If
  35.         Loop
  36.         SecondPercent = Cells(Rr, Cr)
  37.         'Calculate AdjustedPercent
  38.         AdjustedPercent = (SecondPercent - FirstPercent) / nDays
  39.         'Write AdjustedPercent in "Adjusted" column
  40.         For Ra = Rd + 1 To Rr
  41.             Cells(Ra, Ca).Select
  42.             Selection.NumberFormat = "0.0000%" 'Format cell as percent
  43.             Cells(Ra, Ca) = AdjustedPercent
  44.         Next Ra
  45.         Rd = Rr
  46.     Loop Until IsEmpty(Cells(Rd + 1, Cd)) 'No more days
  47. End Sub

Share this Question
Share on Google+
4 Replies


100+
P: 759
This code solve your problem.
Note that the code will not work if you change the data position in sheet.
If you do that you must change the constants values.

In attached workbooks (.xls and .xlsm) go to Sheet2 and press Adjust button to see the results.
The code is also in Sheet2 .

Expand|Select|Wrap|Line Numbers
  1. Option Explicit
  2. Const Cd As Long = 2 ' "Date" column (B)
  3. Const Cr As Long = 4 ' "Returns" column (D)
  4. '    Const Cr As Long = Cd + 2 'This is declared relative to Cd
  5. Const Ca As Long = 5 ' "Adjust" column (E)
  6. '    Const Ca As Long = Cd + 3 'This is declared relative to Cd
  7. '    Const Ca As Long = Cr + 1 'This is declared relative to Cr
  8. Const FirstRow As Long = 5 ' First row with data in your table
  9.  
  10. Dim Msg As VbMsgBoxResult 'Working variable
  11.  
  12. Private Sub cmdStartAdjust_Click()
  13.  
  14. Dim Rd As Long 'Row in "Date" column
  15. Dim Rr As Long 'Row in "Returns" column
  16. Dim Ra As Long 'Row in "Adjusted" column
  17.  
  18. Dim FirstPercent As Double, SecondPercent As Double, AdjustedPercent As Double
  19. Dim nDays As Long 'Number of days for adjustement
  20.  
  21.     Rd = FirstRow
  22.     Do
  23.         FirstPercent = Cells(Rd, Cr)
  24.         'Find the SecondPercent and number of days
  25.         nDays = 1
  26.         Rr = Rd + 1
  27.         Do Until Not IsEmpty(Cells(Rr, Cr))
  28.             Rr = Rr + 1
  29.             nDays = nDays + 1
  30.             If IsEmpty(Cells(Rr, Cd)) Then
  31.                 'The last date has not a "Returns" value
  32.                 Msg = MsgBox("No end for ""Returns""", vbCritical)
  33. Exit Sub
  34.             End If
  35.         Loop
  36.         SecondPercent = Cells(Rr, Cr)
  37.         'Calculate AdjustedPercent
  38.         AdjustedPercent = (SecondPercent - FirstPercent) / nDays
  39.         'Write AdjustedPercent in "Adjusted" column
  40.         For Ra = Rd + 1 To Rr
  41.             Cells(Ra, Ca).Select
  42.             Selection.NumberFormat = "0.0000%" 'Format cell as percent
  43.             Cells(Ra, Ca) = AdjustedPercent
  44.         Next Ra
  45.         Rd = Rr
  46.     Loop Until IsEmpty(Cells(Rd + 1, Cd)) 'No more days
  47. End Sub
Attached Files
File Type: zip Test_Interpolation.zip (44.8 KB, 35 views)
Apr 2 '12 #2

NeoPa
Expert Mod 15k+
P: 31,418
Chanko,
Please consider posting your example data in the thread itself, rather than as an attachment. Attachments cause much more overhead for a reader of your thread than being able to read the question on the page. Many readers will not bother to go to the extra effort, especially if they can't clearly and easily see what your question is.
Apr 2 '12 #3

P: 5
Mihail: Much appreciated - I'm going to work on this and will advise if I need further assistance.
NeoPa: Understand - thanks for letting me know.

These excel forums are amazing! Thanks again.
Apr 2 '12 #4

P: 5
Mihail: A few adjustments here and there from my end but the code worked perfectly. Cheers.
Apr 3 '12 #5

Post your reply

Sign in to post your reply or Sign up for a free account.