Custom function problem

C

Cresta

Hello All and Help! (Hope this makes sence)

=Sum2DProduct(ProfitMons,C$8,ProfitCodes,$BD11,Profit)
All ranges are within the same file.

I have the above custom function that works well when the file is active.
However, when a different file is active then the custom function returns a
value of '0'.

I'm guessing the function isn't referencing anything to do with the file it
is in, only the ranges selected for the funtion. And is applying itself to
the wrong active file.

How do I get the function to apply itself to the file it belongs to.

Thanks
 
C

Cresta

Public Function Sum2DProduct(Header1Range As Range, _
Header1Criteria As Range, _
Column1Range As Range, _
Column1Criteria As Range, _
DataRange As Range, _
Optional Header2Range As Variant, _
Optional Header2Criteria As Variant, _
Optional Header3Range As Variant, _
Optional Header3Criteria As Variant, _
Optional Column2Range As Variant, _
Optional Column2Criteria As Variant, _
Optional Column3Range As Variant, _
Optional Column3Criteria As Variant) As Double
'---
Dim aHeaderCell As Range
Dim aColumn1Cell As Range, aColumn2Cell As Range, aColumn3Cell As Range
Dim cCount As Integer, rCount As Integer
Dim result As Variant
Dim DataSheetVal As String
Dim DataRangeTopRow As Integer, DataRangeBotRow As Integer
Dim H1Match As Boolean, H2Match As Boolean, H3Match As Boolean, Continue
As Boolean
'---
dd$ = ActiveCell.Formula
For i% = 1 To Len(dd$)
If Mid(dd$, i%, 1) = "[" Then
dd1% = i% + 1

End If
If Mid(dd$, i%, 1) = "]" Then
dd2% = i%
tempstring = Mid(dd$, dd1%, dd2% - dd1%)
Exit For
End If
Next
result = 0
Continue = False
For Each aHeaderCell In Header1Range.Cells
If aHeaderCell.Value = Header1Criteria.Value Then
H1Match = True
cCount = aHeaderCell.Column
If IsMissing(Header2Range) = False Then
If Header2Criteria.Value <> "" Then
If Header2Range.Cells(1, cCount).Value =
Header2Criteria.Value Then
H2Match = True
Else
H2Match = False
End If
Else
H2Match = True
End If
Else
H2Match = True
End If
If IsMissing(Header3Range) = False Then
If Header3Criteria.Value <> "" Then
If Header3Range.Cells(1, cCount).Value =
Header3Criteria.Value Then
H3Match = True
Else
H3Match = False
End If
Else
H3Match = True
End If
Else
H3Match = True
End If
Else
H1Match = False
End If
If H1Match = True Then
If H2Match = True Then
If H3Match = True Then
Continue = True
Exit For
End If
End If
End If

Next
On Error GoTo errhelp:
If Continue = False Then
Sum2DProduct = 0
Exit Function
Else
DataRangeTopRow = DataRange.Row
DataRangeBotRow = DataRange.Rows.Count - 1 + DataRangeTopRow
DataSheetVal = DataRange.Worksheet.Name

C1TopRow = Column1Range.Row
C1BotRow = Column1Range.Rows.Count - 1 + C1TopRow
C1Column = Column1Range.Column
C1SheetVal = Column1Range.Worksheet.Name


If IsMissing(Column1Criteria) Then cr1 = True
If IsMissing(Column2Criteria) Then cr2 = True
If IsMissing(Column3Criteria) Then cr3 = True

If cr1 = True Then result = 0
If cr1 = False And cr2 = True And cr3 = False Then
result =
WorksheetFunction.SumIfs(Workbooks(tempstring).Sheets(DataSheetVal).Range(Range(Cells(DataRangeTopRow,
cCount), Cells(DataRangeBotRow, cCount)).Address), Column1Range,
Column1Criteria, Column3Range, Column3Criteria)
End If
If cr1 = False And cr2 = False And cr3 = False Then
result =
WorksheetFunction.SumIfs(Workbooks(tempstring).Sheets(DataSheetVal).Range(Range(Cells(DataRangeTopRow,
cCount), Cells(DataRangeBotRow, cCount)).Address), Column1Range,
Column1Criteria, Column2Range, Column2Criteria, Column3Range, Column3Criteria)
End If
If cr1 = False And cr2 = False And cr3 = True Then
result =
WorksheetFunction.SumIfs(Workbooks(tempstring).Sheets(DataSheetVal).Range(Range(Cells(DataRangeTopRow,
cCount), Cells(DataRangeBotRow, cCount)).Address), Column1Range,
Column1Criteria, Column2Range, Column2Criteria)
End If
If cr1 = False And cr2 = True And cr3 = True Then
Workbooks(tempstring).Activate
result =
WorksheetFunction.SumIfs(Workbooks(tempstring).Sheets(DataSheetVal).Range(Range(Cells(DataRangeTopRow,
cCount), Cells(DataRangeBotRow, cCount)).Address),
Sheets(C1SheetVal).Range(Range(Cells(DataRangeTopRow, C1Column),
Cells(DataRangeBotRow, C1Column)).Address), Column1Criteria)
End If
Sum2DProduct = result
End If

Exit Function
errhelp:
If Err.Number = 9 Then
Else
MsgBox Err.Number & " " & Err.Description
End If
End Function




Hope this helps
 
B

Bob Phillips

Never use Activecell, it points at the activesheet, use

Application.Caller.Formula

Why do you need this UDF, couldn't it be done by formulae?

--
__________________________________
HTH

Bob

Cresta said:
Public Function Sum2DProduct(Header1Range As Range, _
Header1Criteria As Range, _
Column1Range As Range, _
Column1Criteria As Range, _
DataRange As Range, _
Optional Header2Range As Variant, _
Optional Header2Criteria As Variant, _
Optional Header3Range As Variant, _
Optional Header3Criteria As Variant, _
Optional Column2Range As Variant, _
Optional Column2Criteria As Variant, _
Optional Column3Range As Variant, _
Optional Column3Criteria As Variant) As Double
'---
Dim aHeaderCell As Range
Dim aColumn1Cell As Range, aColumn2Cell As Range, aColumn3Cell As Range
Dim cCount As Integer, rCount As Integer
Dim result As Variant
Dim DataSheetVal As String
Dim DataRangeTopRow As Integer, DataRangeBotRow As Integer
Dim H1Match As Boolean, H2Match As Boolean, H3Match As Boolean,
Continue
As Boolean
'---
dd$ = ActiveCell.Formula
For i% = 1 To Len(dd$)
If Mid(dd$, i%, 1) = "[" Then
dd1% = i% + 1

End If
If Mid(dd$, i%, 1) = "]" Then
dd2% = i%
tempstring = Mid(dd$, dd1%, dd2% - dd1%)
Exit For
End If
Next
result = 0
Continue = False
For Each aHeaderCell In Header1Range.Cells
If aHeaderCell.Value = Header1Criteria.Value Then
H1Match = True
cCount = aHeaderCell.Column
If IsMissing(Header2Range) = False Then
If Header2Criteria.Value <> "" Then
If Header2Range.Cells(1, cCount).Value =
Header2Criteria.Value Then
H2Match = True
Else
H2Match = False
End If
Else
H2Match = True
End If
Else
H2Match = True
End If
If IsMissing(Header3Range) = False Then
If Header3Criteria.Value <> "" Then
If Header3Range.Cells(1, cCount).Value =
Header3Criteria.Value Then
H3Match = True
Else
H3Match = False
End If
Else
H3Match = True
End If
Else
H3Match = True
End If
Else
H1Match = False
End If
If H1Match = True Then
If H2Match = True Then
If H3Match = True Then
Continue = True
Exit For
End If
End If
End If

Next
On Error GoTo errhelp:
If Continue = False Then
Sum2DProduct = 0
Exit Function
Else
DataRangeTopRow = DataRange.Row
DataRangeBotRow = DataRange.Rows.Count - 1 + DataRangeTopRow
DataSheetVal = DataRange.Worksheet.Name

C1TopRow = Column1Range.Row
C1BotRow = Column1Range.Rows.Count - 1 + C1TopRow
C1Column = Column1Range.Column
C1SheetVal = Column1Range.Worksheet.Name


If IsMissing(Column1Criteria) Then cr1 = True
If IsMissing(Column2Criteria) Then cr2 = True
If IsMissing(Column3Criteria) Then cr3 = True

If cr1 = True Then result = 0
If cr1 = False And cr2 = True And cr3 = False Then
result =
WorksheetFunction.SumIfs(Workbooks(tempstring).Sheets(DataSheetVal).Range(Range(Cells(DataRangeTopRow,
cCount), Cells(DataRangeBotRow, cCount)).Address), Column1Range,
Column1Criteria, Column3Range, Column3Criteria)
End If
If cr1 = False And cr2 = False And cr3 = False Then
result =
WorksheetFunction.SumIfs(Workbooks(tempstring).Sheets(DataSheetVal).Range(Range(Cells(DataRangeTopRow,
cCount), Cells(DataRangeBotRow, cCount)).Address), Column1Range,
Column1Criteria, Column2Range, Column2Criteria, Column3Range,
Column3Criteria)
End If
If cr1 = False And cr2 = False And cr3 = True Then
result =
WorksheetFunction.SumIfs(Workbooks(tempstring).Sheets(DataSheetVal).Range(Range(Cells(DataRangeTopRow,
cCount), Cells(DataRangeBotRow, cCount)).Address), Column1Range,
Column1Criteria, Column2Range, Column2Criteria)
End If
If cr1 = False And cr2 = True And cr3 = True Then
Workbooks(tempstring).Activate
result =
WorksheetFunction.SumIfs(Workbooks(tempstring).Sheets(DataSheetVal).Range(Range(Cells(DataRangeTopRow,
cCount), Cells(DataRangeBotRow, cCount)).Address),
Sheets(C1SheetVal).Range(Range(Cells(DataRangeTopRow, C1Column),
Cells(DataRangeBotRow, C1Column)).Address), Column1Criteria)
End If
Sum2DProduct = result
End If

Exit Function
errhelp:
If Err.Number = 9 Then
Else
MsgBox Err.Number & " " & Err.Description
End If
End Function




Hope this helps

royUK said:
What's the code in the custom function?


--
royUK

Hope that helps, RoyUK
For tips & examples visit my 'web site' (http://www.excel-it.com/)
Click to expand...
Click to expand...
 
N

Niek Otten

What's the code of the function and how do you call it? What are the values
of the arguments?
What do you think it should return and why?
 
C

Cresta

=Sum2DProduct(Header1Range ,Header1Criteria ,Column1Range ,Column1Criteria
,DataRange )

At the moment we use an array formula to do the searching throught a mass of
data and it takes quite a long time to do it. I have been asked to see if a
UDF can be developed to replace it and speed it up. The UDF below works when
the file is the active file and is much quicker. But it falls over when it is
not the active file and is being calculated using F9 calculating all open
workbooks.

We have looked at using the new SumIfs but I think I am correct in saying it
only works in one direction, although with many criterias along that
direction.
We need to scan along the top of the data to match the month (may be more
that one column) then down the codes on the right to match a code number (may
be more than one row). Then return the sum of the cells identified.

The logic of returning the data isn't the issue, it's the inability to have
the UDF perform when it isn't the active file.

Hope this helps
Any ideas
 
C

Cresta

Unfortunately not.

I replaced the ActiveCell with Application.Caller but it didn't make any
difference

I also added Application.Volitile (True) as suggested elsewhere on the net.

Any other ideas.

Thanks
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

custom function closed workbooks 3
Application.Caller calls from ActiveWorkbook not the actual cell workbook 1
Help file for VBA custom function 2
Custom Function & Application.volatile 2
Custom function acting weird 2
Problems with Custom Functions and Muiltiple open workbooks 8
custom function - finding cell address 4
Function arguments prompt causing problems 0

Top