• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Find the lesser closest date by given date and then multiply the intersect values.

Hi

I need a VBA code to get the below results.

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 by VBA code

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.

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

Hope someone will guide me to get the VBA Code.
 

Attachments

  • Find lesser closest date.xlsx
    12.3 KB · Views: 3
I would like to convert my daily working sheet from normal excel formulas to VBA code as I want to write and learn the working VBA code.

I am just beginner in the VBA code writing. Your help will be very grateful for me.

Thanks in advance.
 
I guess formula in B13 can be =B12*INDEX(Sheet2!$B$2:$I$15,MATCH($D$9,Sheet2!$A$2:$A$15,1),COLUMN(A1))
Simple recording of macro reveals following code (which now can be improved):
Code:
Range("B13").Select
Selection.FormulaR1C1 = _
        "=R[-1]C*INDEX(Sheet2!R2C2:R15C9,MATCH(R9C4,Sheet2!R2C1:R15C1,1),COLUMN(R[-12]C[-1]))"
    Selection.AutoFill Destination:=Range("B13:I13"), Type:=xlFillDefault

Slightly better perhaps like so
Code:
 With Range("B13")
       .FormulaR1C1 = _
        "=R[-1]C*INDEX(Sheet2!R2C2:R15C9,MATCH(R9C4,Sheet2!R2C1:R15C1,1),COLUMN(R[-12]C[-1]))"
        .AutoFill Destination:=Range("B13:I13"), Type:=xlFillDefault
    End With

But for this simple set-up I would simply use a formula-approach.
 
Dear GraH Guido

Thanks a lot for your reply with the solution.

As I want to learn the VBA Code writing,

Can we write the code without using application functions like index and match? Because I want to write the working pure VBA code without using any of the functions as an index match.

Dear Marc L
The expected to result in sheet1 cell D10 is: 281.95 (Check the attached file)

Thanks in advance for you both.
 

Attachments

  • Find lesser closest date.xlsx
    12 KB · Views: 3
As a « pure VBA code » is often less efficient and sometimes slower than using Excel inner features …​
Paste this code to the Sheet1 worksheet module :​
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$D$9" Then
            V = [MATCH(Sheet1!D9,Sheet2!A:A,1)]
        With Target(2)
            If IsError(V) Then .Value2 = "" Else .Value2 = Evaluate(Replace("SUMPRODUCT(Sheet1!B12:I12,Sheet2!B#:I#)", "#", V))
        End With
    End If
End Sub
Do you like it ? So thanks to click on bottom right Like !​
 
Dear Marc L

Thanks for your reply

Check the attachment for your study. it is not giving proper results in the cell D10

Also, the code has an application function of sumproduct which I do not require.

I want the code without using the sumproduct index and match functions.

I hope you can provide an alternate one.

My intention is to learn the pure working VBA code instead of using the same excel formulas inside the codes.

Thanks in advance.
 

Attachments

  • Find lesser closest date.xlsm
    15.7 KB · Views: 3
As it works on my side with your first attachment so you just pasted the code in Sheet2 instead of Sheet1.​
To well understand your error, rename Sheet1 as Date for example, whatever, then check it out !​
Once code is located at the right place, rename the worksheet as original or mod the code …​
If if is only an exact search, VBA has its Find method.​
But for your purpose, VBA has nothing to directly find your row, the reason why using Excel stuff is the best way !​
So if you really want a « pure VBA code » (totally silly but as usual on any forum) explain in plain english text​
what "strategy" you want to apply in order to achieve a very less efficient code ?​
If it respects Logic, I'll try to code that like any very beginner Dumb or Dumber can …​
 
Dear Marc L

After finding the date in column A, Can we use

Set B2I15= Intersect(Columns("B:I"), A.EntireRow)

The below code is for sumproduct formulas results by pure VBA code for your information.

The sum-product formula is =IF(P1=EN2,(SUMPRODUCT((J8:J30495<=EN1)*(J8:J30495>=EO1)*(G8:G30495="Sales")*CF8:CF30495))

But in my case, I need to write the code for SUMPRODUCT and INDEX,MATCH as like below formulas

=IF(P1=EN6,(SUMPRODUCT(CG4:EF4,INDEX('RM Price'!$B$2:$BA$239,MATCH('Master Data'!$EN$1,'RM Price'!$A$2:$A$239),))



Code:
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim J As Range, G As Range, Where As Range
  Dim Low As Date, High As Date
  Dim Dates, Types, Values
  Dim i As Long
  Dim Sum As Double, Sum1 As Double, Sum2 As Double

  'Only if P1 changes
  If Intersect(Target, Range("P1")) Is Nothing Then Exit Sub

  'Get the dates
  Low = Range("EO1").Value
  High = Range("EN1").Value
  'Refer to the used cells in column J
  Set J = Range("J8", Range("J" & Rows.Count).End(xlUp))
  'Same size in column G
  Set G = Intersect(Columns("G"), J.EntireRow)
  'Read in all data
  Dates = J.Value
  Types = G.Value

  Select Case Target.Value
    Case Range("EN2").Value
      'Same size in column CF
      Set Where = Intersect(Columns("CF"), J.EntireRow)
      'Read in all values
      Values = Where.Value
      'Process the SUMPRODUCT
      For i = 1 To UBound(Dates)
        If Dates(i, 1) >= Low And Dates(i, 1) <= High And Types(i, 1) = "Sales" Then
          Sum = Sum + Values(i, 1)
        End If
      Next
End Select

  'Events off, otherwise we call ourself
  Application.EnableEvents = False
  'Write the sum into the sheet
  Range("EL7") = Sum
  'Events on
  Application.EnableEvents = True
End Sub
 
Set B2I15= Intersect(Columns("B:I"), A.EntireRow)
Maybe but I wanna see the codeline where this variable object A is filled …​
A better way if A is a cell within the first column : Set B2I = A(1, 2).Resize(, 8) …​
 
Sorry, I don't know further how to multiply the intersect values and where the object A is filled.

if your time permits please guide me to get the solutions.
 
Solution is already within post #6 following the TEBV main rule (Think Excel Before VBA !) …​
Pro avoid to use any loop when Excel has yet all the necessary : easy code,​
easier to maintain than any gas factory pure VBA code …​
If you want another solution way then follow post #8 : explain in plain english text your logic.​
 
The below code is for sumproduct formulas results by pure VBA code
In fact your code is very not at pure VBA level !​
As a reminder VBA means Visual Basic for Application (here Application is of course Excel).​
So your code is more like a car with a wheel off …​
According to your last attachment from post #7, a pure code at Application level :​
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$D$9" Then
        Application.EnableEvents = False
        V = Application.Match(Target, Sheet1.UsedRange.Columns(1), 1)
        If IsError(V) Then [D10].Value2 = "" Else [D10].Value2 = Application.SumProduct([B12:I12], Sheet1.Cells(V, 2).Resize(, 8))
        Application.EnableEvents = True
    End If
End Sub
You may Like it !
 
To any reader : next code is not the way to go …​
To Anbuselvam K : a demonstration that pro avoid :​
Code:
Function BadlyFindRow(D As Date) As Range
      Const C = "B:I"
        Dim R&
    With Sheet1.[A1].CurrentRegion.Rows
        For R = 2 To .Count
            Select Case .Cells(R, 1).Value
                   Case D
                        Set BadlyFindRow = .Item(R).Columns(C)
                        Exit Function
                   Case Is > D
                        Set BadlyFindRow = .Item(R + (R > 2)).Columns(C)
                        Exit Function
            End Select
        Next
            Set BadlyFindRow = .Item(.Count).Columns(C)
    End With
End Function

Sub BadDemo()
         Dim Rg As Range, D#
    For Each Rg In BadlyFindRow(Sheet2.[D9].Value)
        D = D + Sheet2.Cells(12, Rg.Column).Value2 * Rg.Value2
    Next
        Sheet2.[D10].Value2 = D
End Sub
You should Like it !
 
An equally bad idea, that I supplied on MrE
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
         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
 
Yes as it's not VBA but VBAC : Visual Basic Algorithmic for Children !​
And when the child is not able to explain its homework, its notation is always near zero …​
 
Dear All

I need your valuable support, Almost I finished my code and struck with the last one thing as below

the highlighted code line is taking i = 85 to 136 column number in both sheets.

How do I write the code For i = 85 to 136 in Sheets("Master Data") and For i = 2 to 53 in sheets("RM Price")

Any another way to get the desired results.



Code:
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

Thanks in advance
 
Can anyone help!

How do I write the code For i = 85 to 136 in Sheets("Master Data") and For i = 2 to 53 in sheets("RM Price")

Thanks in advance
 
Hi

I have added two codes here. The code1 is working well, But when I add the code1 into code2 it is showing type mismatch error in Line 92.

Please check the code and give me a solution.


Code1
Code:
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 J = 85 To 136
        For i = 2 To 53
      Sum = Sum + Cells(4, J).Value * FndRow(1, i).Value
        Next i
    Next
    Range("EN10") = Sum / 52
End Sub

Code2
Code:
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim J As Range, G As Range, Where As Range, Colu As Range, Fndrow As Range
  Dim Low As Date, High As Date
  Dim Dates, Types, Values
  Dim i As Long
  Dim Sum As Double, Sum1 As Double, Sum2 As Double

  'Only if P1 changes
  If Intersect(Target, Range("P1")) Is Nothing Then Exit Sub

  'Get the dates
  Low = Range("EO1").Value
  High = Range("EN1").Value
  'Refer to the used cells in column J
  Set J = Range("J8", Range("J" & Rows.Count).End(xlUp))
  'Same size in column G
  Set G = Intersect(Columns("G"), J.EntireRow)
  'Read in all data
  Dates = J.Value
  Types = G.Value

  Select Case Target.Value
    Case Range("EN2").Value
      'Same size in column CF
      Set Where = Intersect(Columns("CF"), J.EntireRow)
      'Read in all values
      Values = Where.Value
      'Process the SUMPRODUCT
      For i = 1 To UBound(Dates)
        If Dates(i, 1) >= Low And Dates(i, 1) <= High And Types(i, 1) = "Sales" Then
          Sum = Sum + Values(i, 1)
        End If
      Next

    Case Range("EN3").Value
      Set Where = Intersect(Columns("T"), J.EntireRow)
      Values = Where.Value
      For i = 1 To UBound(Dates)
        If Dates(i, 1) >= Low And Dates(i, 1) <= High And Types(i, 1) = "Sales" Then
          Sum = Sum + Values(i, 1)
        End If
      Next

    Case Range("EN4").Value
      Set Where = Intersect(Columns("B"), J.EntireRow)
      Dates = Where.Value
      Set Where = Intersect(Columns("CF"), J.EntireRow)
      Values = Where.Value

      For i = 1 To UBound(Dates)
        If Dates(i, 1) <= High Then
          Sum1 = Sum1 + Values(i, 1)
        End If
      Next

      Set Where = Intersect(Columns("CA"), J.EntireRow)
      Values = Where.Value
      Dates = J.Value

      For i = 1 To UBound(Dates)
        If Dates(i, 1) <= High Then
          Sum2 = Sum2 + Values(i, 1)
        End If
      Next
      Sum = Sum1 - Sum2

    Case Range("EN5").Value
      Set Where = Intersect(Columns("BY"), J.EntireRow)
      Values = Where.Value
      'Process the SUMPRODUCT
      For i = 1 To UBound(Dates)
        If Dates(i, 1) >= Low And Dates(i, 1) <= High And Types(i, 1) = "Sales" Then
          Sum = Sum + Values(i, 1)
        End If
      Next

    Case Range("EN6").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 J = 85 To 136
        For i = 2 To 53
      Sum = Sum + Cells(4, i).Value * Fndrow(1, i).Value
        Next i
      Next
        Sum = Sum / 52
    Case Range("EN7").Value
      Set Where = Intersect(Columns("B"), J.EntireRow)
      Dates = Where.Value
      Set Where = Intersect(Columns("CE"), J.EntireRow)
      Values = Where.Value

      For i = 1 To UBound(Dates)
        If Dates(i, 1) <= High Then
          Sum1 = Sum1 + Values(i, 1)
        End If
      Next

      Set Where = Intersect(Columns("BZ"), J.EntireRow)
      Values = Where.Value
      Dates = J.Value

      For i = 1 To UBound(Dates)
        If Dates(i, 1) <= High Then
          Sum2 = Sum2 + Values(i, 1)
        End If
      Next
      Sum = Sum1 - Sum2
  End Select

  'Events off, otherwise we call ourself
  Application.EnableEvents = False
  'Write the sum into the sheet
  Range("EL7") = Sum
  'Events on
  Application.EnableEvents = True
End Sub
 
Back
Top