Interpolating data between two occurrences to work out individual date values

[Chanko]

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.

[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 .

Option Explicit
Const Cd As Long = 2 ' "Date" column (B)
Const Cr As Long = 4 ' "Returns" column (D)
'    Const Cr As Long = Cd + 2 'This is declared relative to Cd
Const Ca As Long = 5 ' "Adjust" column (E)
'    Const Ca As Long = Cd + 3 'This is declared relative to Cd
'    Const Ca As Long = Cr + 1 'This is declared relative to Cr
Const FirstRow As Long = 5 ' First row with data in your table
 
Dim Msg As VbMsgBoxResult 'Working variable
 
Private Sub cmdStartAdjust_Click()
 
Dim Rd As Long 'Row in "Date" column
Dim Rr As Long 'Row in "Returns" column
Dim Ra As Long 'Row in "Adjusted" column
 
Dim FirstPercent As Double, SecondPercent As Double, AdjustedPercent As Double
Dim nDays As Long 'Number of days for adjustement
 
    Rd = FirstRow
    Do
        FirstPercent = Cells(Rd, Cr)
        'Find the SecondPercent and number of days
        nDays = 1
        Rr = Rd + 1
        Do Until Not IsEmpty(Cells(Rr, Cr))
            Rr = Rr + 1
            nDays = nDays + 1
            If IsEmpty(Cells(Rr, Cd)) Then
                'The last date has not a "Returns" value
                Msg = MsgBox("No end for ""Returns""", vbCritical)
Exit Sub
            End If
        Loop
        SecondPercent = Cells(Rr, Cr)
        'Calculate AdjustedPercent
        AdjustedPercent = (SecondPercent - FirstPercent) / nDays
        'Write AdjustedPercent in "Adjusted" column
        For Ra = Rd + 1 To Rr
            Cells(Ra, Ca).Select
            Selection.NumberFormat = "0.0000%" 'Format cell as percent
            Cells(Ra, Ca) = AdjustedPercent
        Next Ra
        Rd = Rr
    Loop Until IsEmpty(Cells(Rd + 1, Cd)) 'No more days
End Sub

[NeoPa]

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.

[Chanko]

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.

[Chanko]

Mihail: A few adjustments here and there from my end but the code worked perfectly. Cheers.