Special Filter Macro - one rngFilter, several Worksheets filtered

[ricowyder]

Good morning,

I've created a special filter using 3 worksheets.

One worksheet contains all data (A1:H1500).
Name: NetRevAndPax

Second sheet should be the one, where the filtered range is pasted
(A1:G1, rows not defined).
Name: FiltNetRev

Third sheet is the one, where the filter criteria is entered (just one
customer ID number, E8:E9).
Name: CREATE

In this third sheet, I have written the Sub (it is not a module, but
the sub is in the worksheet):

Sub Worksheet_Change(ByVal Target As Range)
Dim rngDB As Range
Dim rngFilter As Range
Dim rngOutput As Range

Set rngDB = Worksheets("NetRevAndPax").Range("A1:H1500")
Set rngFilter = Worksheets("CREATE").Range("E8:E9")
Set rngOutput = Worksheets("FiltNetRev").Range("A1:H1")

If Not (Application.Intersect(rngFilter, Target) Is Nothing) Then
rngDB.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngFilter, _
CopyToRange:=rngOutput, _
Unique:=False
End If

Set rngDB = Nothing
Set rngFilter = Nothing
Set rngOutput = Nothing
End Sub

So far, everything works fine. When I enter the number, the data is
retrieved from one worksheet and copied in the other one (FiltNetRev).

However, my job is not done yet and I NEED YOUR HELP.

I want to be able to enter that number, but the job should not only be
done once (in worksheet NetRevandPax to FiltNetRev), but also from
several other worksheets (e.g. Data2 to Event02 and Data3 to Event3). I
have around 10 data sheets and would create around 10 event sheets,
where the filtered data should be copied in.
ALWAYS BASED ON THE SAME ENTRY I DO ONCE IN THE WORKSHEET "CREATE".

Maybe I have started wrong by putting the macro in the worksheet (not
in a module)
or
maybe I need to programm it completely new?

Please help! I need your help, because I cannot move ahead... Thanks to
anybody contributing to it.

Best regards,

Rico

 

[paul.robinson]

Hi
1. Insert a code module into your project in VBA using Insert,
Module...
2. Paste in your worksheet change sub, but call it something else.
Remove the reference to Target.
e.g.
Sub MyFilter()
Dim rngDB As Range
Dim rngFilter As Range
Dim rngOutput As Range

Set rngDB = Worksheets("NetRevAndPax").Range("A1:H1500")
Set rngFilter = Worksheets("CREATE").Range("E8:E9")
Set rngOutput = Worksheets("FiltNetRev").Range("A1:H1")

rngDB.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngFilter, _
CopyToRange:=rngOutput, _
Unique:=False
End If
Set rngDB = Nothing
Set rngFilter = Nothing
Set rngOutput = Nothing
end sub

3. In Excel, put a form button on the "CREATE" worksheet using View,
Toolbars, Forms. When the toolbar appears, click on the button Tool and
draw a button on your worksheet. When prompted for a name, select the
macro above.

4. This macro will work for your rngDB sheet to rngOutputSheet. You now
need to call this sub for the other sheets, which means you need some
parameters in it. Change the sub to this one;

Sub MyFilter(rngDB as Range, rngOutput as Range)
Dim rngFilter As Range

Set rngFilter = Worksheets("CREATE").Range("E8:E9")
rngDB.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngFilter, _
CopyToRange:=rngOutput, _
Unique:=False
End If
Set rngFilter = Nothing
end sub

and create this new sub
Sub MyFilter()
Dim InputRange(1 to 3) as Range 'an array with 3 ranges in it
Dim OutPutRange(1 to 3) as Range
Dim i as integer

Set InputRange(1) = Worksheets("NetRevAndPax").Range("A1:H1500")
Set OutputRange(1) = Worksheets("FiltNetRev").Range("A1:H1")
'do same for 2 and 3

'call myFilter for each Range
For i = 1 to 3
Call myFilter InputRange(i), OutputRange(i)
Set inputrange(i) = nothing
set outputRange(i) = nothing
next i
end sub

finally, it is this second sub you want to attach to the button on the
Filter sheet, so right click it and assign this second macro to it.

This is untested, but should be about right!
regards
Paul

 

[Mike Fogleman]

First of all I would move the code to a general module because you need to
work with multiple sheets and Advanced Filter. Fire it from a CommandButton
on your CREATE sheet. Then create a loop through the necessary worksheets,
changing the rngDB and rngOutput references to properly pair them up.

Dim i as Long
Dim rngDB As Range
Dim rngFilter As Range
Dim rngOutput As Range

Set rngFilter = Worksheets("CREATE").Range("E8:E9")
For i = 2 to Worksheets.Count
Set rngDB = Worksheets(i).Range("A1:H1500")
Set rngOutput = Worksheets(i + 1).Range("A1:H1")
rngDB.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngFilter, _
CopyToRange:=rngOutput, _
Unique:=False
i = i + 2
Next
End Sub

You will need to work out how to properly pair up your sheets depending upon
where they are in your workbook.
Mike F

 

[ricowyder]

Hi Paul,

Thanks a lot for your answer! Great!

I got a little confused with how many sub I need to create, but finally
I only need the last one right? (Asking because you named all MyFilter,
which causes a syntax error by using them simultaneously). Or do I need
to put them in different modules so that I get no error message?

I named now all sheets after Event1, 2, 3... and Data1, 2, 3...
Here is a test after your description for 2 Sheets:

Sub MyFilter()
Dim InputRange(1 To 2) As Range 'an array with 3 ranges in it
Dim OutPutRange(1 To 2) As Range
Dim i As Integer


Set InputRange(1) = Worksheets("Data1").Range("A1:H1500")
Set OutPutRange(1) = Worksheets("Event1").Range("A1:H1")

Set InputRange(2) = Worksheets("Data2").Range("A1:G1500")
Set OutPutRange(2) = Worksheets("Event2").Range("A1:G1")

'call myFilter for each Range
For i = 1 To 2
Call myFilter InputRange(i), OutputRange(i)
Set InputRange(i) = Nothing
Set OutPutRange(i) = Nothing
Next i
End Sub

Is that all I need to paste in the module I created? Thanks for your
generous help.

Regards,

Rico

 

[ricowyder]

Thanks Michael,

This is definitely a great way to do it. I tried it before I tried
Pauls version. But then I realised that I have to change the Ranges for
each sheet. Therefore I will try Paul's version now. But nevertheless,
I am really, really thankful for your reply. This website can only
exist with such generous people.

Best regards

Rico

 

[paul.robinson]

Hi
Sorry, I gave two subs the same name. you want,
Sub MyFilter(rngDB as Range, rngOutput as Range)
Dim rngFilter As Range
Set rngFilter = Worksheets("CREATE").Range("E8:E9")
rngDB.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngFilter, _
CopyToRange:=rngOutput, _
Unique:=False
End If
Set rngFilter = Nothing
end sub

and create this new sub
Sub CopyRanges()
Dim InputRange(1 to 3) as Range 'an array with 3 ranges in it
Dim OutPutRange(1 to 3) as Range
Dim i as integer

Set InputRange(1) = Worksheets("NetRevAndPax").Range("A1:H1500")
Set OutputRange(1) = Worksheets("FiltNetRev").Range("A1:H1")
'do same for 2 and 3

'call myFilter for each Range
For i = 1 to 3
Call myFilter InputRange(i), OutputRange(i)
Set inputrange(i) = nothing
set outputRange(i) = nothing
next i
end sub

You put them both in the same module and attach CopyRanges to the
button.

apologies again
Paul

 

[ricowyder]

Hi Paul,

I did as you told me (and launch the sub by the create button). But I
receive again an error for the line
Call MyFilter InputRange(i), OutputRange(i)

I already corrected the m (myFilter -> MyFilter). But then, InputRange
seems to be the problem now.
Any ideas? Thanks a lot and please: no apologies, because YOU are
helping ME out! ;-).

Regards,

Rico

 

[ricowyder]

I forgot: here is what I have now in my module besides the first sub:


Sub CopyRanges()
Dim InputRange(1 To 3) As Range 'an array with 3 ranges in it
Dim OutPutRange(1 To 3) As Range
Dim i As Integer


Set InputRange(1) = Worksheets("Data1").Range("A1:H1500")
Set OutPutRange(1) = Worksheets("Event1").Range("A1:H1")

Set InputRange(2) = Worksheets("Data2").Range("A1:G1500")
Set OutPutRange(2) = Worksheets("Event2").Range("A1:G1")

Set InputRange(3) = Worksheets("Data3").Range("A3:I1500")
Set OutPutRange(3) = Worksheets("Event3").Range("A3:I3")
'do same for 2 and 3


'call myFilter for each Range
For i = 1 To 3
Call MyFilter InputRange(i), OutputRange(i)
Set InputRange(i) = Nothing
Set OutPutRange(i) = Nothing
Next i
End Sub

 

[paul.robinson]

Hi
My mistake again!
Use
MyFilter InputRange(i), OutputRange(i)

or you can use
Call MyFilter(InputRange(i), OutputRange(i))

(note the brackets)

regards
Paul

 

[ricowyder]

Hi Paul,

Sorry, but still, there is a bug (between rngDB.AdvancedFilter_ until
Set rgnFilter= Nothing)... I know, I know, I am bothering you... but
please check it again. Thank you soooo much.

Sub MyFilter(rngDB As Range, rngOutput As Range)
Dim rngFilter As Range

Set rngFilter = Worksheets("CREATE").Range("E8:E9")
rngDB.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngFilter, _
CopyToRange:=rngOutput, _
Unique:=False
Set rngFilter = Nothing
End Sub

Sub CopyRanges()
Dim InputRange(1 To 3) As Range 'an array with 3 ranges in it
Dim OutPutRange(1 To 3) As Range
Dim i As Integer


Set InputRange(1) = Worksheets("Data1").Range("A1:H1500")
Set OutPutRange(1) = Worksheets("Event1").Range("A1:H1")

Set InputRange(2) = Worksheets("Data2").Range("A1:G1500")
Set OutPutRange(2) = Worksheets("Event2").Range("A1:G1")

Set InputRange(3) = Worksheets("Data3").Range("A3:I1500")
Set OutPutRange(3) = Worksheets("Event3").Range("A3:I3")
'do same for 2 and 3


'call myFilter for each Range
For i = 1 To 3
Call MyFilter(InputRange(i), OutPutRange(i))
Set InputRange(i) = Nothing
Set OutPutRange(i) = Nothing
Next i
End Sub