425,830 Members | 682 Online
+ 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
 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)
38.         AdjustedPercent = (SecondPercent - FirstPercent) / nDays
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

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)
38.         AdjustedPercent = (SecondPercent - FirstPercent) / nDays
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
 Test_Interpolation.zip (44.8 KB, 35 views)
Apr 2 '12 #2

 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