This may be easier to incorporate

Sub filterforpart()
With Range("H2:H22")
.AutoFilter Field:=1, Criteria1:="=*te*"
.Offset(1).Copy Range("k4")
.AutoFilter
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
.AutoFilter
End With
End Sub


--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"DavidH56" wrote in message
...
Hello,

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.
NameCrit

'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
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Summary").Range("W1:W2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
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"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("U:W").Delete
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.
--
By persisting in your path, though you forfeit the little, you gain the
great.