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
No comments:
Post a Comment