ADDING SUM BASED ON TODAYS DATE

[sidxl]

I have revenue report which includes date column and sale which is placed on a1 and b1 respectively
i need a macro code which can give me result of sum of ranges starting from b2 to todays date corresponding sale
And a code to find the sale ranging from two dates (start date and end date)

Thanks in Advance!!

PFA Sample revenue report

 

[Harry Covair]

Hi sidxl,
try this as procedure in sheet1

Sub cond_sum()
Dim ws As Worksheet, lastrow As Long, myrange As Range, rng As Range, tot As Long
Set ws = Worksheets("sheet1")
ws.Activate
lastrow = ws.Cells(1, 1).End(xlDown).Row
For Each rng In Range("A2", Cells(lastrow, 1))
If rng <= Now() Then
    tot = tot + rng.Offset(, 1).Value
    End If
    Next
    MsgBox tot
End Sub

Harry

 

[Harry Covair]

and this one

Sub sumbetwdate()
Dim ws As Worksheet, lastrow As Long, rng As Range, tot As Long
Dim D_Begin As Date
Dim D_End As Date
D_Begin = InputBox("Date begin")
D_End = InputBox("Date end")
Set ws = Worksheets("sheet1")
ws.Activate
lastrow = ws.Cells(1, 1).End(xlDown).Row
For Each rng In Range("A2", Cells(lastrow, 1))
 If rng >= D_Begin And rng <= D_End Then
    tot = tot + rng.Offset(, 1).Value
    End If
    Next
    MsgBox tot
End Sub

Harry

 

[sidxl]

Thanks Harry
it works great on my sample sheet !!
but gets error when i use it on other workbooks
and i cant assign this code to button also
please guide me !!

 

[Harry Covair]

Hi sidxl,
Assuming you created, in the sheet that contains the data, two activeX buttons which names (not the caption) are btn_Tot_Today and btn_Tot_Between, replace the existing code by this one. Even if you change the name of the worksheet, the code remains operational.
Harry

Private Sub btn_Tot_Today_Click()

Dim ws As Worksheet, lastrow As Long, myrange As Range, rng As Range, tot As Long

Set ws = Worksheets(ActiveSheet.Name)

lastrow = ws.Cells(1, 1).End(xlDown).Row

For Each rng In Range("A2", Cells(lastrow, 1))

If rng <= Now() Then

  tot = tot + rng.Offset(, 1).Value

  End If

  Next

  MsgBox tot

End Sub

Private Sub btn_Tot_Between_Click()

Dim ws As Worksheet, lastrow As Long, rng As Range, tot As Long

Dim D_Begin As Date

Dim D_End As Date

D_Begin = InputBox("Date begin")

D_End = InputBox("Date end")

Set ws = Worksheets(ActiveSheet.Name)

lastrow = ws.Cells(1, 1).End(xlDown).Row

For Each rng In Range("A2", Cells(lastrow, 1))

 If rng >= D_Begin And rng <= D_End Then

  tot = tot + rng.Offset(, 1).Value

  End If

  Next

  MsgBox tot

End Sub

 

[sidxl]

Thanks a lot Mr Harry !!
Now it works like charm !!