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]

 

[Anbuselvam]

Dear Fluff

Thanks for your code

There is only one correction required,

When I enter any date or after the date of sheet2 column A last date of 04-Apr-19 in the target cell it is showing MsgBox "date not found"

Actually it should take closest date to the given date.

The logic is, Sheet2 list of dates in the column A is the date when prices changed, So last price change was 04-Apr-19

So after all the date from 04-Apr-2019 it should take the intersect values until further dates to be takes place.

https://www.dropbox.com/s/xt7p5j32i1a9jv9/Find closest date.xlsm?dl=0

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

 

[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
         Set FndRw = Sheet1.Range("A" & Rows.Count).End(xlUp)
      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

 

[Anbuselvam]

Dear Fluff

Thanks a lot for you

The code is working perfectly!

 

[Fluff]

You're welcome & thanks for the feedback.

 

[Anbuselvam]

Dear Fluff

Please check the below linked file and the code.

I transferred your code for my similar requirements as below.

https://www.dropbox.com/s/pj6l30omcgz8yqs/Fluff MrE.xlsm?dl=0

Case Range("EN6").Value
      For Each Colu In Sheets("RM Price").Range("A2", Sheets("RM Price").Range("A" & Rows.Count).End(xlUp))
      If Colu.Value = High Then
      Set Fndrow = Colu
      Exit For
      ElseIf Colu.Value > High Then
      Set Fndrow = Colu.Offset(-1)
      Exit For
      End If
      Next Colu
      If Fndrow Is Nothing Then
      Set Fndrow = Sheets("RM Price").Range("A" & Rows.Count).End(xlUp)
      End If
      For i = 85 To 136
      Sum = Sum + Cells(4, i).Value * Fndrow(1, i).Value
      Next i

The above code is not giving the desired results. In the attached sheet I have full VBA code for your study and modification.

Note:
VBA results are coming in ("EL7")
For verification similar results are shown in ("EL1") by excel formulation.

All results and code execute when ("P1") value changes by its drop down list.

Please do the needful.

Thanks in advance

 

[Fluff]

I have absolutely no idea what you're code is trying to do.
Also I do not understand why you are trying to avoid using worksheet functions. It's like trying to re-invent the wheel.
Therefore I cannot help any further.

 

[Anbuselvam]

Thanks!

 

[Anbuselvam]

Dear Fluff & Dante Amor

I have almost change the code for my requirements, I struck with one last thing. Can you please guide to get desired results if your time permits.

In the below line i = 85 to 136 is correct as the data from Sheets("Master Data")

But in the sheets("RM Price") i = 2 to 53

In this case how do i change the code?

For i = 85 To 136
Sum = Sum + Cells(4, i).Value * FndRow(1, i).Value

https://www.dropbox.com/s/pj6l30omcgz8yqs/Fluff MrE.xlsm?dl=0

Sub indexmatch()
Dim colu As Range, FndRow As Range
Dim High As Date
Dim i As Long
Dim Sum As Double


    High = Range("EN1").Value
    For Each colu In Sheet2.Range("A2", Sheet2.Range("A" & Rows.Count).End(xlUp))
      If colu.Value = High Then
      Set FndRow = colu
      Exit For
      ElseIf colu.Value > High Then
      Set FndRow = colu.Offset(-1)
      Exit For
      End If
      Next colu
      If FndRow Is Nothing Then
      Set FndRow = Sheet2.Range("A" & Rows.Count).End(xlUp)
      End If
      For i = 85 To 136
      Sum = Sum + Cells(4, i).Value * FndRow(1, i).Value
      Next i
      Range("EN10") = Sum
End Sub

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
         Set FndRw = Sheet1.Range("A" & Rows.Count).End(xlUp)
      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