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

[Anbuselvam]

[FONT=&quot]Hi[/FONT]

[FONT=&quot]In the attached workbook [/FONT]

[FONT=&quot]Sheet1, Cell D9 is the given date and the cell B12: H12 is the data range[/FONT]

[FONT=&quot]Sheet2 A2: A15 is the list of dates where we need to lookup the given date or the closest date[/FONT]

[FONT=&quot]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)[/FONT]

[FONT=&quot]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. [/FONT]

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/td4ggsbx7r1zbu3/Find closest date.xlsx?dl=0

[FONT=&quot]If same Date present in the list then the same date intersecting values to multiply.

[/FONT][FONT=&quot]I need a pure working VBA code to get the below results without using SUMPRODUCT, INDEX and MATCH Functions inside the code.

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

[FONT=&quot]Hope someone will guide me to get the VBA Code.[/FONT]

 

[Fluff]

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.

Please supply the links, here and on the other site(s) where you have asked this question.

 

[DanteAmor]

Please, put this link in the other sites where you asked, so you can review the following answer.

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.

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

Sub find_closest2()
    Range("D10") = Evaluate("=SUMPRODUCT(B12:I12,OFFSET(Sheet2!A1,MATCH(D9,Sheet2!A1:A15,1)-1,1,,8))")
End Sub

 

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

Thanks in advance

 

[Fluff]

@Anbuselvam
Please supply links to the other sites as requested.
This is not an option.

 

[DanteAmor]

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.

Thanks in advance

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

Read this to understand why

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

 

[Anbuselvam]

https://chandoo.org/forum/threads/f...tiply-the-intersect-values.41661/#post-248167

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

Read this to understand why

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

 

[Fluff]

Thanks for supplying the link.

 

[Fluff]

How about

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
         MsgBox "Date not found"
         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

 

[DanteAmor]

https://chandoo.org/forum/threads/f...tiply-the-intersect-values.41661/#post-248167

Thanks for helping to help you