Problem with advanced filter macro




I've been trying to data extract to new sheets using Debra Danglish's
ExtractRep code. The code works great except for trying to filter out text
that is contained within cells sometimes behind other text. For instance I
want to filter TE out of DARFMTEA in row 3 and TERS45 in row 4. Please see
my code below.

Sub ExtractWorkTypInfo()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Summary")
Set rng = Range("Database")

'Create a list of Tank Criteria
'This is where I copy my range List to Column W.
'This list contains things like TE,RF, etc.. up to 30 items.
'I put in the header name in row one.

'ws1.Columns("W:W").Copy _
' Destination:=Range("Z1") '- only if you use the full list
ws1.Columns("W:W").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("U1"), Unique:=True
r = Cells(Rows.Count, "U").End(xlUp).Row

'set up Criteria Area
Range("W1").Value = Range("A1").Value

For Each c In Range("U2:U" & r)
'add the tank name to the criteria area
ws1.Range("W2").Value = c.Value
'add new sheet (if required)
'and run advanced filter

If WksExists(c.Value) Then
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Summary").Range("W1:W2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Summary").Range("W1:W2"), _
CopyToRange:=wsNew.Range("A1"), _
End If
End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

The my source column is column A.
Any help you provide would be greatly appreciated.

Don Guillett

This may be easier to incorporate

Sub filterforpart()
With Range("H2:H22")
.AutoFilter Field:=1, Criteria1:="=*te*"
.Offset(1).Copy Range("k4")
End With
End Sub

or change your copy desination to suit
Sub filterforpartloop()
With Range("H2:H22")
Dim c
For Each c In Range("l2:l3")
.AutoFilter Field:=1, Criteria1:="=*" & c & "*"
.Offset(1).Copy c.Offset(, 1)
Next c
End With
End Sub


I thiink you need to add an auxilarry formula. Use find to put a one in a
new column which you can use as a filter



Thanks for the quick response Joel.
I took yout advice and this is what I've placed in column Z:
Now if you could help me with how to filter the 1's to create
separate new sheets.

Thank you.


Not sure which part of the code you want to filter since there are two places
where you have advance filter. You can use autofilter (I used column E) and
then copy the visible cells.

Columns("E").AutoFilter Field:=1, Criteria1:="1"

field 1 is column E since only one column is spedified in the autofilter.

Debra Dalgleish

Change your code to include asterisks with the criteria, as Don
suggested. In your code, the revised line would be:

For Each c In Range("U2:U" & r)
'add the tank name to the criteria area
ws1.Range("W2").Value = "*" & c.Value & "*" <===add asterisks


Thank you both Debra and Joel fo your response. I will test it and get back
with you on the results.

Once Again,
Thank you.


Thanks you so much Debra,
This works to perfection. Thank you for your expertise and your time.

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question