To add one more filter option in vba

[hanim554]

Dear Friends,

I have found below from net suitable for my requirement and managed to do some changes, sample file attached here with.
In the sheet test I can select date and click on show data which will bring all data falling between out date and in date, i have another filter 'Name', when i select the Name, it should bring only that name which is in column O, i am stcuck here, cant go ahead, appreciated if any one can help.

Sub testextract()
Sheets("test").Select
Range("B21:O20000").Select
Selection.ClearContents
Sheets("test").Select
Dim r As Range, r1 As Range, Sh As Worksheet, sh1 As Worksheet
Dim cell As Range, rDate As Range, v As Variant
Dim dt As Date, dt1 As Date, i As Long, rw As Long
Dim cell1 As Range, bHidden As Boolean
v = Array("ismail", "vijendra", "aashik", "sabeena", "gyzel", "khodr", "simmi")
Set Sh = Worksheets("test")
Set rDate = Sh.Range("F2")
' dt will hold the date of the last day of the month for the date in D6
'dt = DateSerial(Year(rDate), Month(rDate) + 1, 0)
dt = Sh.Range("AS17")
dt1 = Sh.Range("AT17")
For i = LBound(v) To UBound(v)
Set sh1 = Worksheets(v(i))
Set r = sh1.Range("C3:C1000")
For Each cell In r
bHidden = False
Set cell1 = cell.Offset(0, 12).Resize(1, 1) ' H:AD
If cell >= dt Then
If cell <= dt1 Then
'If Application.CountIf(cell1, "<>""") > 0 Then
rw = Sh.Cells(Sh.Rows.Count, "C").End(xlUp).Row + 1
If cell.EntireRow.Hidden = True Then bHidden = True
'cell.EntireRow.Hidden = False
cell.EntireRow.Copy
If rw < 21 Then rw = 21
Sh.Cells(rw, 1).PasteSpecial xlValues
'Sh.Cells(rw, 1).PasteSpecial xlFormats
End If
End If
If bHidden = True Then cell.EntireRow.Hidden = True
Next cell
Next i
End Sub

Regards
Hanim

 

[Smallman]

Hi Hanim

As you got the code online you won't mind me saying that the code you picked up is really poorly constructed. It will take a long time to run relative to what it should take. I can post a sample of a smaller file I will make with all of the names of the sheets you have but it would be better if you posted a sample file which seems to be missing.

In the mean time I will create a file which will Isolate data in Col C between Two Dates and Col O based on a Single Text String.

Take care

Smallman

 

[Smallman]

Here is the code and the file is attached.

Option Explicit
Option Base 1
Sub Consolidate()
Dim dt1 As Long
Dim dt2 As Long
Dim ar As Variant
Dim i As Integer
Dim lr As Long

dt1 = Sheet2.[a2]
dt2 = Sheet2.[b2]
ar = [{"ismail", "vijendra", "aashik", "sabeena", "gyzel", "khodr", "simmi"}]

    For i = 1 To UBound(ar)
        lr = Sheets(ar(i)).Range("C" & Rows.Count).End(xlUp).Row
        Sheets(ar(i)).Range("A2:O" & lr).AutoFilter 3, ">=" & dt1, xlAnd, "<=" & dt2
        Sheets(ar(i)).Range("A2:O" & lr).AutoFilter 15, "Goski"
        Sheets(ar(i)).Range("A3:O" & lr).Copy Sheet2.Range("A" & Rows.Count).End(xlUp)(2)
     Next i

End Sub

Take care

Smallman

 

[hanim554]

Dear Smallman,
Thank you so much for your time, and sorry for missing attached file.
Please find the sample file attached here with. it will give clear picture what i am giving to achieve.
thanks in advance.

Regards
Hanim

 

[Debraj]

In case if you are looking for VBA base approach.. I am sure @Smallman will came with great idea..

for the time being.. try this..

In B21..

=IFERROR(INDEX((INDIRECT($AV$18&"!$"&CHAR(COLUMN(B$1)+64)&"$1:$"&CHAR(COLUMN(B$1)+64)&"$100")),SMALL(IF((INDIRECT($AV$18&"!c1:c100")>=$AS$17)*(INDIRECT($AV$18&"!c1:c100")<=$AT$17),ROW($A$1:$A$100)),ROW(A1))),"")

confirm the formula by using Ctrl + Shift + Enter, not just Enter..

 

[hanim554]

In case if you are looking for VBA base approach.. I am sure @Smallman will came with great idea..

for the time being.. try this..

In B21..

=IFERROR(INDEX((INDIRECT($AV$18&"!$"&CHAR(COLUMN(B$1)+64)&"$1:$"&CHAR(COLUMN(B$1)+64)&"$100")),SMALL(IF((INDIRECT($AV$18&"!c1:c100")>=$AS$17)*(INDIRECT($AV$18&"!c1:c100")<=$AT$17),ROW($A$1:$A$100)),ROW(A1))),"")

confirm the formula by using Ctrl + Shift + Enter, not just Enter..

Dear DEB,
thank you... it works like miracle.. you are really great..i prefer VBA code for the same.

one more thing =DEC2HEX(3563) it is new to me, how i do same for my name. let me hit my brain



Regards
Hanim

 

[Debraj]

Ok then in case of VBA.. lets try below one...

Sub testextract()
  [b20].CurrentRegion.ClearContents
  Sheets([AV20].Value).[b2].CurrentRegion.AdvancedFilter 2, [as19:at20], [b20]
End Sub

 

[hanim554]

Dear DEB,

thank you so much for your help and sorry for late reply, i only open my gmail today after dat day, i had recorded advanced filter and get it done, now i will change with your code, it is simple and powerful. thank u so much again.

Regards
Hanim