Turning a function from serving current worksheet to specific worksheet

[ahmadmasri]

Hello

I am new to excel macros ,, and i am loving it ,,, but i still have problems refering to sheets other than the active sheets

I have this function i got through the net, it is working when it is working on active sheet, but it is not working when i refer to a different sheet from a different workbook

and i am always getting errors

Function DistinctValues(InputValues As Variant, _
    Optional IgnoreCase As Boolean = False) As Variant


Dim ResultArray() As Variant
Dim UB As Long
Dim TransposeAtEnd As Boolean
Dim N As Long
Dim ResultIndex As Long
Dim M As Long
Dim ElementFoundInResults As Boolean
Dim NumCells As Long
Dim ReturnSize As Long
Dim Comp As VbCompareMethod
Dim V As Variant



Directory = "D:\xxxxx\Test Files\"

Set wb_SSR_tmp = Workbooks.Open(Directory & "test.xlsm")
Set sht1_tmp = wb_SSR_tmp.Sheets(1)


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Set the text comparison value to be used by StrComp based on
' the setting of IgnoreCase.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If IgnoreCase = True Then
    Comp = vbTextCompare
Else
    Comp = vbBinaryCompare
End If


If IsObject(Application.Caller) = True Then
    If Application.Caller.Rows.Count > 1 And Application.Caller.Columns.Count > 1 Then
        DistinctValues = CVErr(xlErrRef)
        Exit Function
    End If
    ''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Save the size of the region from which the
    ' function was called and save a flag indicating
    ' whether we need to transpose the result upon
    ' returning.
    ''''''''''''''''''''''''''''''''''''''''''''''''''
    If Application.Caller.Rows.Count > 1 Then
        TransposeAtEnd = True
        ReturnSize = Application.Caller.Rows.Count
    Else
        TransposeAtEnd = False
        ReturnSize = Application.Caller.Columns.Count
    End If
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Were we passed a Range object or a VBA array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If IsObject(InputValues) = True Then
    If TypeOf InputValues Is Excel.Range Then
        ''''''''''''''''''''''''''''''''''''''''''''''''
        ' Input is a Range object.
        ''''''''''''''''''''''''''''''''''''''''''''''''
        If InputValues.Rows.Count > 1 And InputValues.Columns.Count > 1 Then
            DistinctValues = CVErr(xlErrRef)
            Exit Function
        End If
        If InputValues.Rows.Count > 1 Then
            NumCells = InputValues.Rows.Count
        Else
            NumCells = InputValues.Columns.Count
        End If
        UB = NumCells
    Else
        DistinctValues = CVErr(xlErrRef)
        Exit Function
    End If
Else
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' InputValues is not a Range object.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    If IsArray(InputValues) = True Then
        Select Case NumberOfArrayDimensions(InputValues)
            Case 0
                ''''''''''''''''''''''''''''''''''''
                ' Zero dimensional array (scalar).
                ' Return an array of 1 element with
                ' that value.
                ''''''''''''''''''''''''''''''''''''
                ReDim ResultArray(1 To 1)
                ResultArray(1) = InputValues
                DistinctValues = ResultArray
                Exit Function
            Case 1
                UB = UBound(InputValues) - LBound(InputValues) + 1
                '''''''''''''''''''''''''''''''''''''''''''''''''''''''
                ' If we were passed in an array from a worksheet
                ' function (e.g., =DISTINCTVALUES({1,2,3}), we
                ' need to set NumCells to the size of the input array.
                ' This is used later to properly resize the result array.
                '''''''''''''''''''''''''''''''''''''''''''''''''''''''
                If IsObject(InputValues) = False Then
                    NumCells = UB
                End If
            Case Else
                DistinctValues = CVErr(xlErrValue)
                Exit Function
        End Select
    Else
        ReDim ResultArray(1 To 1)
        ResultArray(1) = InputValues
        DistinctValues = ResultArray
        Exit Function
    End If
End If
       



'For N = LBound(InputValues) To UBound(InputValues)
For Each V In InputValues
    If IsNull(V) = True Then
        DistinctValues = CVErr(xlErrNull)
        Exit Function
    End If
    If IsObject(V) = True Then
        If Not TypeOf V Is Excel.Range Then
            DistinctValues = CVErr(xlErrValue)
            Exit Function
        End If
    End If
Next V
       
''''''''''''''''''''''''''''''''''''''''''''''''''
' Allocate the ResultArray and fill it with either
' vbNullStrings if we were called from a worksheet
' or with Empty values if called by a VB procedure.
'''''''''''''''''''''''''''''''''''''''''''''''''''
ReDim ResultArray(1 To UB)
For N = LBound(ResultArray) To UBound(ResultArray)
    If IsObject(Application.Caller) = True Then
        ResultArray(N) = vbNullString
    Else
        ResultArray(N) = Empty
    End If
Next N




ResultIndex = 1
''''''''''''''''''''''''''''''''''''
' We can always assume that the
' first element in the InputValues
' will be distinct so far.


ResultArray(1) = InputValues(1)

' Loop throught the entire InputValues
' array.

For N = 2 To UB
    '''''''''''''''''''''''''''''''''
    ' Set our Found flag = False. This
    ' flag is used to indicate whether
    ' we find Input(N) in the list of
    ' distinct elements. If we found it
    ' earlier, it is no longer a distinct
    ' element and we won't put it in the
    ' ResultArray.
    ''''''''''''''''''''''''''''''''''''
    ElementFoundInResults = False
    For M = 1 To N
        '''''''''''''''''''''''''''''''''''''
        ' Scan through the array ResultArray
        ' looking for Input(N). If we find it,
        ' Input(N) is a duplicate so set the
        ' Found flag to True.
        '''''''''''''''''''''''''''''''''''''
        If StrComp(CStr(ResultArray(M)), CStr(InputValues(N)), Comp) = 0 Then
            ElementFoundInResults = True
            Exit For
        End If
    Next M
    ''''''''''''''''''''''''''''''''''''''''''''
    ' If we didn't find Input(N) in ResultArray
    ' then Input(N) is distinct so we increment
    ' ResultIndexand add Input(N) to ResultArray.
    ''''''''''''''''''''''''''''''''''''''''''''
    If ElementFoundInResults = False Then
        ResultIndex = ResultIndex + 1
        ResultArray(ResultIndex) = InputValues(N)
    End If
Next N

If ReturnSize <> 0 Then
    If ResultIndex < NumCells Then
        If ResultIndex < ReturnSize Then
            ResultIndex = ReturnSize
        End If
    End If
End If

ReDim Preserve ResultArray(1 To ResultIndex)
For N = NumCells + 1 To ReturnSize
    ResultArray(N) = vbNullString
Next N


If TransposeAtEnd = True Then
    DistinctValues = Transpose1DArray(Arr:=ResultArray, ToRow:=False)
Else
    DistinctValues = ResultArray
End If

End Function


Function TransposeArray(Arr As Variant) As Variant


Dim R1 As Long
Dim R2 As Long
Dim C1 As Long
Dim C2 As Long
Dim LB1 As Long
Dim LB2 As Long
Dim UB1 As Long
Dim UB2 As Long

Dim Res() As Variant
Dim NumDims As Long

If IsArray(Arr) = False Then
    TransposeArray = Arr
    Exit Function
End If

NumDims = NumberOfArrayDimensions(Arr)
Select Case NumDims
    Case 0
        If IsObject(Arr) = True Then
            Set TransposeArray = Arr
        Else
            TransposeArray = Arr
        End If
    Case 1
        TransposeArray = Arr
    Case 2
        LB1 = LBound(Arr, 1)
        UB1 = UBound(Arr, 1)
        LB2 = LBound(Arr, 2)
        UB2 = UBound(Arr, 2)
        R2 = LB1
        C2 = LB2
        ReDim Res(LB2 To UB2, LB1 To UB1)
        For R1 = LB1 To UB1
            For C1 = LB2 To UB2
                Res(C1, R1) = Arr(R1, C1)
                C2 = C2 + 1
            Next C1
        R2 = R2 + 1
        Next R1
        TransposeArray = Res
    Case Else
        TransposeArray = CVErr(9)
End Select

End Function

Function NumberOfArrayDimensions(Arr As Variant) As Long

Dim LB As Long
Dim N As Long

On Error Resume Next
N = 1
Do Until Err.Number <> 0
    LB = LBound(Arr, N)
    N = N + 1
Loop
NumberOfArrayDimensions = N - 2

End Function

Function Transpose1DArray(Arr As Variant, ToRow As Boolean) As Variant


Dim Res As Variant
Dim N As Long

If IsArray(Arr) = False Then
    Transpose1DArray = CVErr(xlErrValue)
    Exit Function
End If
If NumberOfArrayDimensions(Arr) <> 1 Then
    Transpose1DArray = CVErr(xlErrValue)
    Exit Function
End If

If ToRow = True Then
    ReDim Res(LBound(Arr) To LBound(Arr), LBound(Arr) To UBound(Arr))
    For N = LBound(Res, 2) To UBound(Res, 2)
        Res(LBound(Res), N) = Arr(N)
    Next N
Else
    ReDim Res(LBound(Arr) To UBound(Arr), LBound(Arr) To LBound(Arr))
    For N = LBound(Res, 1) To UBound(Res, 1)
        Res(N, LBound(Res)) = Arr(N)
    Next N
End If
Transpose1DArray = Res

End Function

[ahmadmasri]

any ideas how to start ?

[ahmadmasri]

i think it has relation of variable being identified as object ,,, it is just frustrating

[ahmadmasri]

it worked as below:

but can anyone tell me what with statement changes exactly ?

With sht1_tmp ' Without this with, the ode will make problems refering to other sheets

Set reasons_Range = sht1_tmp.Range("J2:J" & sht1_tmp.Range("J" & sht1_tmp.Rows.Count).End(xlUp).Row)

End With