Filter records using arrays (VBA)

Vishesh's picture

Put the following code in a general module and run. You can download the attachment as well to see how it works.


 

Sub TestIt()

    Dim rngTgt As Range

    Dim arr

 

'Target where you want to see filtered data

    Set rngTgt = Sheet1.Range("J2")

    rngTgt.CurrentRegion.Offset(1).ClearContents

    

'Calling function with parameters

    arr = FilterRange(Sheet1.Range("A1").CurrentRegion, Sheet1.Range("F1"), Sheet1.Range("F2"), Sheet1.Range("G1"), Sheet1.Range("G2"), Sheet1.Range("H1"), Sheet1.Range("H2"))

    

    If Not IsEmpty(arr) Then

        rngTgt.Resize(UBound(arr, 1) + 1, UBound(arr, 2) + 1) = arr

    End If

End Sub

 

Function FilterRange(rngWithHeader As Range, ParamArray arrFldnCrit() As Variant) As Variant

'ParamArray arrFldnCrit - it should be field name then field value (criteria) e.g.

'Field1, Value1, Field2, Value2 and so on...

    Dim arrRng

    Dim i As Long

    Dim y As Integer

    Dim x As Integer

    Dim intCntCond As Integer

    Dim intCntMatch As Integer

    Dim lngLoopArr As Long

    

    intCntCond = (UBound(arrFldnCrit) + 1) / 2

    

    ReDim arrFld(0)

    ReDim arrCrit(0)

    ReDim arrfldcol(0)

    

    For i = LBound(arrFldnCrit) To UBound(arrFldnCrit)

        If i Mod 2 = 0 Then

            If i <> 0 Then ReDim Preserve arrFld(UBound(arrFld) + 1)

            arrFld(UBound(arrFld)) = arrFldnCrit(i)

        Else

            If i > 1 Then ReDim Preserve arrCrit(UBound(arrCrit) + 1)

            arrCrit(UBound(arrCrit)) = arrFldnCrit(i)

        End If

    Next i

    

    arrRng = rngWithHeader

    

    ReDim arrTemp(UBound(arrRng, 1) - 1, UBound(arrRng, 2) - 1)

    

    For y = LBound(arrFld) To UBound(arrFld)

        For i = LBound(arrRng, 2) To UBound(arrRng, 2)

            If arrFld(y) = arrRng(1, i) Then

                If y <> LBound(arrFld) Then

                    ReDim Preserve arrfldcol(UBound(arrfldcol) + 1)

                End If

                arrfldcol(UBound(arrfldcol)) = i

            End If

        Next i

    Next y

    

    y = 0

    For lngLoopArr = LBound(arrRng, 1) To UBound(arrRng, 1)

        intCntMatch = 0

        For i = 1 To intCntCond

            If arrRng(lngLoopArr, arrfldcol(i - 1)) = arrCrit(i - 1) Then

                intCntMatch = intCntMatch + 1

            End If

        Next i

        If intCntCond = intCntMatch Then

            y = y + 1

            For x = LBound(arrRng, 2) To UBound(arrRng, 2)

                arrTemp(y - 1, x - 1) = arrRng(lngLoopArr, x)

            Next x

        End If

    Next lngLoopArr

    If y = 0 Then Exit Function

    ReDim arrFinal(y - 1, UBound(arrRng, 2) - 1)

    For x = LBound(arrFinal, 1) To UBound(arrFinal, 1)

        For y = LBound(arrFinal, 2) To UBound(arrFinal, 2)

            arrFinal(x, y) = arrTemp(x, y)

        Next y

    Next x

    

    FilterRange = arrFinal

End Function

 

 

AttachmentSize
FilterMultiCriteria.xlsm19.75 KB

Nice Work Vishesh

I like to add a filter button according to my data in excel...

for your understanding here is one sample

Here is my criteria for advance filter, every time i go to data>sort&filter>advance to run.

Company Name Status Date of Paymt Date of Paymt
ABC Co. Paid 1-Feb 15-Feb

here below is my data as an example to filter according to my above criteria.

S.No. Company Name Invoice date Invoice # Description Invoice Amount Status Date of Paymt
1 ABC Co. 2-Jan xxx1 xxxxxxxx 1000 Paid 3-Feb
2 EFG Co. 2-Jan xxx2 xxxxxxxx 12000 Paid 3-Feb
3 ABC Co. 2-Feb xxx3 xxxxxxxx 15000 Not Paid -
4 XYZ Co. 2-Jan xxx4 xxxxxxxx 20000 Paid 3-Feb
5 EFG Co. 2-Feb xxx5 xxxxxxxx 3500 Not Paid -
6 XYZ Co. 2-Feb xxx6 xxxxxxxx 12000 Not Paid -

i want to make a Apply filter button as you did. I m not good in VB, i dont really understand the code language. I want apply filter button for myself to easy the process and also for those who are connected in my work.

it will be great help if you help me to make this. here is my email shaikmohammed81@yahoo.com for contact.

Vishesh's picture

Would suggest you to give it

Would suggest you to give it a try based on the attachment. If you don't get it right then I will try to help or guide you.