Hi there,
Take a look at the attached workbook and see if it does what you need.
It uses a combination of "native" Excel functions and VBA functions because using the SUMPRODUCT function in VBA can sometimes be less than straightforward!
The formula entered in the worksheet is as follows:
=SUMPRODUCT( (PartNos(B6) = $C$2) * (Dates(B6) <= $C$3) * (SubTotals(B6)) )
Where Cell B6 contains the name of the worksheet (month) for which the calculation is being performed, Cell C2 contains the relevant Part Number, and Cell C3 contains the latest date which should be taken into consideration.
The "PartNos", "Dates" and "SubTotals" functions are defined in VBA as follows:
Option Explicit
'=========================================================================================
'=========================================================================================
Const msFIRST_CELL__SUBTOTAL As String = "D4"
Const msFIRST_CELL__PART_NO As String = "B4"
Const msFIRST_CELL__DATE As String = "D1"
'=========================================================================================
'=========================================================================================
Function Dates(SheetName As String) As Range
Dim rFirstCell As Range
Dim rLastCell As Range
Dim wks As Worksheet
Set wks = ThisWorkbook.Worksheets(SheetName)
Set rFirstCell = wks.Range(msFIRST_CELL__DATE)
Set rLastCell = rFirstCell.End(xlToRight)
Set Dates = Range(rFirstCell, rLastCell)
End Function
'=========================================================================================
'=========================================================================================
Function PartNos(SheetName As String) As Range
Dim rFirstCell As Range
Dim rLastCell As Range
Dim wks As Worksheet
Set wks = ThisWorkbook.Worksheets(SheetName)
Set rFirstCell = wks.Range(msFIRST_CELL__PART_NO)
Set rLastCell = rFirstCell.End(xlDown)
Set PartNos = Range(rFirstCell, rLastCell)
End Function
'=========================================================================================
'=========================================================================================
Function SubTotals(SheetName As String) As Range
Dim rLastPartNoCell As Range
Dim rLastDateCell As Range
Dim rFirstCell As Range
Dim rLastCell As Range
Dim wks As Worksheet
Set wks = ThisWorkbook.Worksheets(SheetName)
Set rFirstCell = wks.Range(msFIRST_CELL__SUBTOTAL)
Set rLastDateCell = wks.Range(msFIRST_CELL__DATE).End(xlToRight)
Set rLastPartNoCell = wks.Range(msFIRST_CELL__PART_NO).End(xlDown)
Set rLastCell = Intersect(rLastPartNoCell.EntireRow, _
rLastDateCell.EntireColumn)
Set SubTotals = Range(rFirstCell, rLastCell)
End Function
The highlighted values may be altered to suit your worksheet layout requirements.
Hope this helps - please let me know how you get on.
Regards,
Greg M
Bookmarks