example using DSUM worksheet function in a VBA function

[excelman]

Does anyone have sample code of using
WorksheetFunction.DSum(rDB, rColumn, rCriteria) in a VBA function?

 

[sebastienm]

Hi,

MsgBox Application.WorksheetFunction.DSum(Range("A18"), Range("C1"),
Range("G3:G4"))

with:
- the table (headers + data): A18
- the sum field header in C1 (here 'Data')
- the criteria as G3 being the header name (here 'Description') and G4 the
filter value for that header (here 'Gasket')

returns the correct value in my case.

 

[excelman]

Hi,
What is the best way to dynamically change the criteria to sum all the
fields in the Data column in a loop
Thanks

 

[sebastienm]

Could you please give a few examples.

The DSUM function requires that you write the criteria table to the sheet.
Instead, you could use the SUMPRODUCT function.

Say you have:
- A2:A100 : data for field Gender
- B2:B100: data for field Age
- C2:C100: data for field Sales

To get the sum of Sales for males (="M") older than 30yr-old(>30), you would
use the formula:
= SUMPRODUCT( (A2:A100="M") * (B2:B100>30) * (C2:C100) )

Note that it also allow wildcard charactyers, ie A2:A100="*" would return
the sum for all genders.

In vba you would use:

Sub test()
'sum Sales for Males of age >30
MsgBox GetSum(Range("C2:C100"), "=""M""", ">30")
End Sub

Function GetSum(ColToSum As Range, GenderCriteria As String, AgeCriteria As
String)
Dim s As String
s = "= SUMPRODUCT( (" _
& Application.Intersect(ColToSum.EntireRow, _
ColToSum.Parent.Range("A2").EntireColumn).Address _
& GenderCriteria & ") * (" _
& Application.Intersect(ColToSum.EntireRow, _
ColToSum.Parent.Range("B2").EntireColumn).Address _
& AgeCriteria & ") * (" _
& ColToSum.Address & ")) "
GetSum = Application.Evaluate(s)
End Function

Finally to get sevral SUM columns, using the GetSum function above, you
would do something like :
Sub test()
Dim i As Long, rgToSum As Range
Dim firstCol As String, lastCol As String, rowsToSUm As String
Dim GCriteria As String, ACriteria As String

'sum from col C to E
firstCol = "C"
lastCol = "E"
rowsToSUm = "2:100"
GCriteria = "=""M"""
ACriteria = ">30"

For i = Asc(firstCol) To Asc(lastCol)
Set rgToSum = Application.Intersect(Range(rowsToSUm), Range(Chr(i) &
":" & Chr(i)))
MsgBox GetSum(rgToSum, GCriteria, ACriteria)
Next i
End Sub