# Thread: find the closest date and multiply the intersecting row values by VBA Code Thanks: 0 Likes:  1 Post #5276210 (1)

1. ## find the closest date and multiply the intersecting row values by VBA Code

Hi

In the attached workbook

Sheet1, Cell D9 is the given date and the cell B12: H12 is the data range

Sheet2 A2: A15 is the list of dates where we need to lookup the given date or the closest date

In the list of dates in Sheet2, none is matching Sheet1, D9 dates of 13-Mar-19. So then It has to select the closest lesser dates of D9(13-Mar-19) which is (09-Mar-19)

Then the intersecting values of B2: H15 need to multiply by Sheet1 cell B12: H12 values and the results must be shown in D10 of Sheet 1.

The below link sheet I got a results by using SUMPRODUCT formula and to found the date I did not add the formulas.

https://www.dropbox.com/s/td4ggsbx7r...date.xlsx?dl=0

If same Date present in the list then the same date intersecting values to multiply.

I need a pure working VBA code to get the below results without using SUMPRODUCT, INDEX and MATCH Functions inside the code.

I want to learn VBA code as I have many similar formulas in other sheets to be changed in VBA Code

Hope someone will guide me to get the VBA Code.

2. ## Re: find the closest date and multiply the intersecting row values by VBA Code

Cross posted
While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

3. ## Re: find the closest date and multiply the intersecting row values by VBA Code

I show you 2 options, the first one performs step by step, the search, the multiplication and the sum. The second one reacts in one step the whole operation.

Code:
```Sub find_closest_date()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim f As Variant, lr As Long, acum As Double, i As Long

Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")

lr = sh2.Range("A" & Rows.Count).End(xlUp).Row
f = WorksheetFunction.Match(sh1.Range("D9"), sh2.Range("A1:A" & lr), 1)
If Not IsError(f) Then
For i = Columns("B").Column To Columns("I").Column
acum = acum + (sh1.Cells(12, i) * sh2.Cells(f, i))
Next
End If
Range("D10") = acum
End Sub```
Code:
```Sub find_closest2()
Range("D10") = Evaluate("=SUMPRODUCT(B12:I12,OFFSET(Sheet2!A1,MATCH(D9,Sheet2!A1:A15,1)-1,1,,8))")
End Sub```

4. ## Re: find the closest date and multiply the intersecting row values by VBA Code

Dear Dante Amor

Thanks a lot for your code and it is working well.

If your time permits can you provide another code without using worksheet function Match?

my intention is to learn pure working VBA code without worksheet functions.

5. ## Re: find the closest date and multiply the intersecting row values by VBA Code

@Anbuselvam
This is not an option.

6. ## Re: find the closest date and multiply the intersecting row values by VBA Code

Originally Posted by Anbuselvam
Dear Dante Amor

Thanks a lot for your code and it is working well.

If your time permits can you provide another code without using worksheet function Match?

my intention is to learn pure working VBA code without worksheet functions.

With pleasure, but you must put here the links of the other forums; and in the other forums put this link.

https://www.excelguru.ca/content.php?184

7. ## Re: find the closest date and multiply the intersecting row values by VBA Code

Originally Posted by DanteAmor
With pleasure, but you must put here the links of the other forums; and in the other forums put this link.

https://www.excelguru.ca/content.php?184

9. ## Re: find the closest date and multiply the intersecting row values by VBA Code

Code:
```Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cl As Range, FndRw As Range
Dim i As Long
Dim MySum As Double

If Target.CountLarge > 1 Then Exit Sub
If Target.Address(0, 0) = "D9" Then
For Each Cl In Sheet1.Range("A2", Sheet1.Range("A" & Rows.Count).End(xlUp))
If Cl.Value = Target.Value Then
Set FndRw = Cl
Exit For
ElseIf Cl.Value > Target.Value Then
Set FndRw = Cl.Offset(-1)
Exit For
End If
Next Cl
If FndRw Is Nothing Then
Exit Sub
End If
For i = 2 To 9
MySum = MySum + Cells(12, i).Value * FndRw(1, i).Value
Next i
Target.Offset(1).Value = MySum
End If
End Sub```