Filter Array : Revised

Here is an faster and easier way to filter 2D Array

Syntex to Use :

FilterArray InputArray, ResultArray, FilterColumn, FilterValue, FilterType

               

==============================================================================

Enum Combination

    xlRow

    xlColumn

End Enum

Enum FltType

    xlFilterEqualTo

    xlFilterLessThen

    xlFilterLessThenEqualTo

    xlFilterGreaterThen

    xlFilterGreaterThenEqualTo

    xlFilterDoesNotEqualTo

    xlFilterContains

    xlFilterDoesNotContain

   

End Enum

============================================================================== 

Function FilterArray(InputArray As Variant, ResultArray As Variant, FilterColumn As Long, FilterValue As Variant, FilterType As FltType) As Boolean

  

' Created by Rajan 11-July-2012

    ' How to Use :

    ' Parameter Info

    ' InputArray : 2D Array which need to be FIlter

    ' ResultArray : in which Filterd Data will be stored

    ' FilterCOlumn : On Which column you want to apply Filter

    ' Filter Type  : Select a Condition

    ' Syntex :

    ' FilterArray InputArray,ResultArray,FilterColumn,"Product1",xlFilterContains

    '

    'if you want to apply Filter on Row , just Transpose the InputArray and Pass in this Function :)

    '           

    Dim blnFlag     As Boolean

    Dim blnMatch    As Boolean

    Dim lngCount    As Long

    Dim lngCount2   As Long

    Dim lngCount3   As Long

    Dim VarTempResult

    Dim VarTEmp

    lngCount2 = 1

   

    If IsArray(InputArray) Then

        If UBound(InputArray) <= 0 Then

            blnFlag = True

            GoTo ExitEarly:

        End If

        Else

        blnFlag = True

        GoTo ExitEarly:

    End If

  

    If FilterValue = "" Then

        blnFlag = True

        GoTo ExitEarly:

    End If

    ReDim VarTEmp(UBound(InputArray))

   

    For lngCount = LBound(InputArray) To UBound(InputArray)

  

        Select Case FilterType

      

            Case xlFilterContains

                If InStr(InputArray(lngCount, FilterColumn), FilterValue) Then blnMatch = True

            Case xlFilterDoesNotContain

                If InStr(InputArray(lngCount, FilterColumn), FilterValue) = 0 Then blnMatch = True

            Case xlFilterDoesNotEqualTo

                If InputArray(lngCount, FilterColumn) <> FilterValue Then blnMatch = True

            Case xlFilterEqualTo

                If InputArray(lngCount, FilterColumn) = FilterValue Then blnMatch = True

            Case xlFilterGreaterThen

                If InputArray(lngCount, FilterColumn) > FilterValue Then blnMatch = True

            Case xlFilterGreaterThenEqualTo

                If InputArray(lngCount, FilterColumn) >= FilterValue Then blnMatch = True

            Case xlFilterLessThen

                If InputArray(lngCount, FilterColumn) < FilterValue Then blnMatch = True

            Case xlFilterLessThenEqualTo

                If InputArray(lngCount, FilterColumn) <= FilterValue Then blnMatch = True

        End Select

   

        If blnMatch Then

            VarTEmp(lngCount2) = lngCount

            lngCount2 = lngCount2 + 1

            blnMatch = False

        End If

    Next

   

    lngCount2 = lngCount2 - 1

    ReDim VarTempResult(1 To lngCount2, 1 To UBound(InputArray, 2))

   

            For lngCount = 1 To lngCount2

                For lngCount3 = 1 To UBound(InputArray, 2)

                    VarTempResult(lngCount, lngCount3) = InputArray(VarTEmp(lngCount), lngCount3)

                Next lngCount3

            Next lngCount

    ResultArray = VarTempResult

  FilterArray=True

ExitEarly:

If blnFlag Then

    FilterArray = False

    ResultArray = Null

End If

End Function

================================================================================

Thanks For reading 

Filter 2D Array [Rows and Columns]

Hi,

Here is a function to filter 2D Array either by Rows and Columns.

Syntex:

FilterArray InputArray , ResultArray , 1 , "Product1",xlFilterDoesNotEqualTo

Suppose you have An Array of Sales Data of Multiple Product , but you need to retrieve data only for one product in another array, Use this :)

================================================================================

Enum Combination

    xlRow

    xlColumn

End Enum

Enum FltType

    xlFilterEqualTo

    xlFilterLessThen

    xlFilterLessThenEqualTo

    xlFilterGreaterThen

    xlFilterGreaterThenEqualTo

    xlFilterDoesNotEqualTo

    xlFilterContains

    xlFilterDoesNotContain

   

End Enum

 =================================================================================

Function FilterArray(InputArray As Variant, ResultArray As Variant, FilterColumn As Long, FilterValue As Variant, FilterType As FltType) As Boolean

   

   

    Dim blnFlag     As Boolean

    Dim blnMatch    As Boolean

    Dim lngCount    As Long

   

    If IsArray(InputArray) Then

        If UBound(InputArray) <= 0 Then

            blnFlag = True

            GoTo ExitEarly:

        End If

        Else

        blnFlag = True

        GoTo ExitEarly:

    End If

   

    If FilterValue = "" Then

        blnFlag = True

        GoTo ExitEarly:

    End If

    For lngCount = LBound(InputArray) To UBound(InputArray)

   

        Select Case FilterType

       

            Case xlFilterContains

                If InStr(InputArray(lngCount, FilterColumn), FilterValue) Then blnMatch = True

            Case xlFilterDoesNotContain

                If InStr(InputArray(lngCount, FilterColumn), FilterValue) = 0 Then blnMatch = True

            Case xlFilterDoesNotEqualTo

                If InputArray(lngCount, FilterColumn) <> FilterValue Then blnMatch = True

            Case xlFilterEqualTo

                If InputArray(lngCount, FilterColumn) = FilterValue Then blnMatch = True

            Case xlFilterGreaterThen

                If InputArray(lngCount, FilterColumn) > FilterValue Then blnMatch = True

            Case xlFilterGreaterThenEqualTo

                If InputArray(lngCount, FilterColumn) >= FilterValue Then blnMatch = True

            Case xlFilterLessThen

                If InputArray(lngCount, FilterColumn) < FilterValue Then blnMatch = True

            Case xlFilterLessThenEqualTo

                If InputArray(lngCount, FilterColumn) <= FilterValue Then blnMatch = True

               

        End Select

       

        Dim ArrTemp

        Dim ArrTemp2

       

        If blnMatch Then

            If Not IsArray(ResultArray) Then

                ResultArray = Application.Index(InputArray, lngCount)

                ResultArray = Application.Transpose(ResultArray)

                ConvertArrayOneD2TwoD ResultArray, ResultArray

                blnMatch = False

            Else

                ArrTemp = Application.Index(InputArray, lngCount)

                ConvertArrayOneD2TwoD ArrTemp, ArrTemp2

                CombineArrayElements ResultArray, ArrTemp2, ResultArray, xlRow

                blnMatch = False

            End If

        End If

   

    Next

ExitEarly:

If blnFlag Then

    FilterArray = False

    ResultArray = Null

End If

End Function

   

 ================================================================================

Private Function CombineArrayElements(ArrFirst As Variant, ArrAdd As Variant, ArrResult As Variant, CombinationOf As Combination) As Boolean

      

      'Created By Rajan 4-July-2012

           

       '---------How to Use-------------------

       'Syntex

       'CombineArrayCol FirstArray ,SecondArray ,ResultArray

          

        '   FirstArray = FirstArray is in which second array need to be combine,Must have atleast on column and Multidimensional

        '   SecondArray = SecondArray is which need to combined with FirstArray,Must have atleast on column and Multidimensional

        '   ResultArray = ResultArray is in which combined array will be stored

        '   CombinationOf = what you want to Combine either Rows or Columns of Two Arrays

        ' This Function Return True if Operation is succesfull and False with NULL Result array if Operation is Not succeed

      

        Dim blnFlag As Boolean

        Dim lngRow As Long

        Dim lngCol As Long

        Dim lngRow2 As Long

        Dim lngCol3 As Long

        Dim VarTemp

       

      On Error Resume Next

      'Validating Array , IsArray

      If CombinationOf = xlColumn Then

        If IsArray(ArrFirst) And IsArray(ArrAdd) Then    ' if Both Parameter is an Array

        'Both array must contain same Row Number

            If UBound(ArrFirst) = UBound(ArrAdd) Then

                ' Both Array must contain atleast One Column

                If UBound(ArrAdd, 2) < 0 Or UBound(ArrFirst, 2) < 0 Then

                       If UBound(ArrFirst) <> UBound(ArrAdd) Then

                            blnFlag = True

                            GoTo ExitEarly:

                        End If

                Else

                                       

                    blnFlag = True

                    GoTo ExitEarly:

                    End If

            Else

                    blnFlag = True

                    GoTo ExitEarly:

                End If

        Else

            blnFlag = True

            GoTo ExitEarly:

        End If

    Else

        If IsArray(ArrFirst) And IsArray(ArrAdd) Then    ' if Both Parameter is an Array

        'Both array must contain same Columns Number

            If UBound(ArrFirst, 2) = UBound(ArrAdd, 2) Then

                ' Both Array must contain atleast One Row

                If UBound(ArrAdd) > 0 Or UBound(ArrFirst) > 0 Then

                    If UBound(ArrFirst, 2) <> UBound(ArrAdd, 2) Then

                        blnFlag = True

                        GoTo ExitEarly:

                    End If

                Else

                    blnFlag = True

                    GoTo ExitEarly:

                End If

            Else

                    blnFlag = True

                    GoTo ExitEarly:

                End If

        Else

            blnFlag = True

            GoTo ExitEarly:

        End If

   

    End If

    On Error GoTo 0

   

    'Defining Row and Column in ResultArray

    If CombinationOf = xlColumn Then

        ReDim VarTemp(LBound(ArrFirst) To UBound(ArrFirst), LBound(ArrFirst, 2) To (UBound(ArrFirst, 2) + UBound(ArrAdd, 2)))

    ElseIf CombinationOf = xlRow Then

        ReDim VarTemp(LBound(ArrFirst) To (UBound(ArrFirst) + UBound(ArrAdd)), LBound(ArrFirst, 2) To UBound(ArrFirst, 2))

    End If

     

  

    'Filling First Array in ResultArray

    For lngCol = LBound(ArrFirst, 2) To UBound(ArrFirst, 2)

        For lngRow = LBound(ArrFirst) To UBound(ArrFirst)

            VarTemp(lngRow, lngCol) = ArrFirst(lngRow, lngCol)

        Next lngRow

    Next lngCol

  

   

    If CombinationOf = xlColumn Then

    lngCol = lngCol - 1

    lngRow = 0

    ElseIf CombinationOf = xlRow Then

    lngRow = lngRow - 1

    lngCol = 0

    End If

  

    'Filling Second Array in ResultArray

    For lngCol2 = LBound(ArrAdd) To UBound(ArrAdd, 2)

        For lngRow2 = LBound(ArrAdd) To UBound(ArrAdd)

            VarTemp(lngRow2 + lngRow, lngCol2 + lngCol) = ArrAdd(lngRow2, lngCol2)

        Next lngRow2

    Next lngCol2

   

    ArrResult = VarTemp

ExitEarly:

      If blnFlag Then

        ArrResult = Null

        CombineArrayElements = False

      Else

        CombineArrayElements = True

      End If

End Function

================================================================================== 

Function ConvertArrayOneD2TwoD(ArrInput As Variant, ArrOutput As Variant)

   

    Dim lngCount As Long

    Dim VarTemp

    ReDim VarTemp(1 To 1, 1 To UBound(ArrInput))

   

    For lngCount = LBound(ArrInput) To UBound(ArrInput)

        VarTemp(1, lngCount) = ArrInput(lngCount)

    Next lngCount

    ArrOutput = VarTemp

   

End Function

Thanks for reading :) Any suggestion and comment would be highly appreciated

  

 Rajan Verma 

Access-SQL Google Groups

Join our Access-SQL Group

Access- Sql Google Groups


Rajan verma

Fill Array One D to Two D

Below function used to fill one dimensional array elements to 2D Array based on Given parameters,

==================================================================================================================================

Enum Combination

    xlRow

    xlColumn

End Enum

Enum FillType

    FillRowWise

    FillColumnWise

End Enum

==================================================================================================================================

Function JustifyArray(varArrInput As Variant, VarArrResult As Variant, TransformIn As Combination, HowMany As Long, HowToFill As FillType) As Boolean

      

    Dim lngRow As Long

    Dim lngCol As Long

    Dim lngTemp As Long

    Dim VarTemp()

    Dim lngCount

    Dim lngRowCount As Long

    Dim lngColCount As Long

    Dim blnFlag As Boolean

   

    If IsArray(varArrInput) Then

       

        If TransformIn = xlColumn Then

            lngCol = HowMany

            lngRow = Int(UBound(varArrInput) / lngCol) + 1

        ElseIf TransformIn = xlRow Then

            lngRow = HowMany

            lngCol = Int(UBound(varArrInput) / lngRow) + 1

        End If

    Else

    blngFlag = True

    End If

   

    If HowToFill = FillColumnWise Then

        lngTemp = lngRow

        lngRow = lngCol

        lngCol = lngTemp

    End If

   

    ReDim VarArrResult(lngRow, lngCol)

   

    lngTemp = LBound(varArrInput)

    For lngRowCount = 0 To lngRow

        For lngColCount = 0 To lngCol

            If lngTemp >= UBound(varArrInput) Then GoTo ExitEarly:

            VarArrResult(lngRowCount, lngColCount) = varArrInput(lngTemp)

            lngTemp = lngTemp + 1

        Next lngColCount

    Next lngRowCount

       

           

ExitEarly:

    If blnFlag Then

       

        VarArrResult = Null

        JustifyArray = False

    End If

End Function

==================================================================================================================================

Enjoy Reading …. 

Combine Array Elements [Rows or Columns]

here is an updated version of my last  function to combine arrays elements. by using this function user can combine columns as well as rows also , 

Enum Combination

    xlRow

    xlColumn

End Enum

Private Function CombineArrayCol(ArrFirst As Variant, ArrAdd As Variant, ArrResult As Variant, CombinationOf As Combination) As Boolean

       

      'Created By Rajan 4-July-2012

            

       '---------How to Use-------------------

       'Syntex

       'CombineArrayCol FirstArray ,SecondArray ,ResultArray

           

        '   FirstArray = FirstArray is in which second array need to be combine,Must have atleast on column and Multidimensional

        '   SecondArray = SecondArray is which need to combined with FirstArray,Must have atleast on column and Multidimensional

        '   ResultArray = ResultArray is in which combined array will be stored

        '   CombinationOf = what you want to Combine either Rows or Columns of Two Arrays

        ' This Function Return True if Operation is succesfull and False with NULL Result array if Operation is Not succeed

       

      Dim blnFlag As Boolean

     

      'Validating Array , IsArray

      If CombinationOf = xlColumn Then

        If IsArray(ArrFirst) And IsArray(ArrAdd) Then    ' if Both Parameter is an Array

        'Both array must contain same Row Number

            If UBound(ArrFirst) = UBound(ArrAdd) Then

                ' Both Array must contain atleast One Column

                If UBound(ArrAdd, 2) < 0 Or UBound(ArrFirst, 2) < 0 Then

                    blnFlag = True

                    GoTo ExitEarly:

                    End If

            Else

                    blnFlag = True

                    GoTo ExitEarly:

                End If

        Else

            blnFlag = True

            GoTo ExitEarly:

        End If

    Else

    

        If IsArray(ArrFirst) And IsArray(ArrAdd) Then    ' if Both Parameter is an Array

        'Both array must contain same Columns Number

            If UBound(ArrFirst, 2) = UBound(ArrAdd, 2) Then

                ' Both Array must contain atleast One Row

                If UBound(ArrAdd) < 0 Or UBound(ArrFirst) < 0 Then

                    blnFlag = True

                    GoTo ExitEarly:

                    End If

            Else

                    blnFlag = True

                    GoTo ExitEarly:

                End If

        Else

            blnFlag = True

            GoTo ExitEarly:

        End If

    

    End If

    'Defining Row and Column in ResultArray

    If CombinationOf = xlColumn Then

        ReDim ArrResult(LBound(ArrFirst) To UBound(ArrFirst), LBound(ArrFirst, 2) To (UBound(ArrFirst, 2) + UBound(ArrAdd, 2)))

    ElseIf CombinationOf = xlRow Then

        ReDim ArrResult(LBound(ArrFirst) To (UBound(ArrFirst) + UBound(ArrAdd)), LBound(ArrFirst, 2) To UBound(ArrFirst, 2))

    End If

   

    Dim lngRow As Long

    Dim lngCol As Long

    Dim lngRow2 As Long

    Dim lngCol3 As Long

   

    'Filling First Array in ResultArray

    For lngCol = LBound(ArrFirst, 2) To UBound(ArrFirst, 2)

        For lngRow = LBound(ArrFirst) To UBound(ArrFirst)

            ArrResult(lngRow, lngCol) = ArrFirst(lngRow, lngCol)

        Next lngRow

    Next lngCol

   

    

    If CombinationOf = xlColumn Then                                                         

    lngCol = lngCol - 1

    lngRow = 0

    ElseIf CombinationOf = xlRow Then

    lngRow = lngRow - 1

    lngCol = 0

    End If

   

    'Filling Second Array in ResultArray

    For lngCol2 = LBound(ArrAdd) To UBound(ArrAdd, 2)

        For lngRow2 = LBound(ArrAdd) To UBound(ArrAdd)

            ArrResult(lngRow2 + lngRow, lngCol2 + lngCol) = ArrAdd(lngRow2, lngCol2)

        Next lngRow2

    Next lngCol2

ExitEarly:

      If blnFlag Then

        ArrResult = Null

        CombineArrayCol = False

      Else

        CombineArrayCol = True

      End If

End Function

Enjoy reading.. 

Rajan