Extracting only when column contains a certain value

[AmyTaylor]

Dear all, please see attached code for automating extracting data from a range (called "database").
It is working perfectly, however what I want to add is a line to say only extract the data when column X in the "database" contains value "01".
Is that possible?
Please let me know if you can help
Love AMY XX

Sub ExtractReps()
'Application.ScreenUpdating = False
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim R As Integer
Dim c As Range
Set ws1 = Sheets("PCT Specific Data")
Set rng = Range("Database")

'extract a list of PCTs
ws1.Columns("H:H").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("BA1"), Unique:=True
R = Cells(Rows.Count, "BA").End(xlUp).Row

'set up Criteria Area
Range("BC1").Value = Range("H1").Value
While R < 301
Wend
For Each c In Range("BA2:BA300")
'For Each c In Range("BA2:BA" & r)
'add the rep name to the criteria area
ws1.Range("BC2").Value = c.Value
'add new sheet and run advanced filter
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("PCT Specific Data").Range("BC1:BC2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Next
ws1.Select
ws1.Columns("BA:BC").Delete
'Application.ScreenUpdating = True
End Sub

[Dave Ramage]

Amy,

Expand your criteria range to BC1:BD2 and set BD1 to [Title Column X], and
BC2 to "*01*" (excluding quotes).

Also, look out for the infinite loop in your code if less than 301 unique
items are found.

Cheers,
Dave

"AmyTaylor" wrote:

>
> Dear all, please see attached code for automating extracting data from a
> range (called "database").
> It is working perfectly, however what I want to add is a line to say
> only extract the data when column X in the "database" contains value
> "01".
> Is that possible?
> Please let me know if you can help
> Love AMY XX
>
> Sub ExtractReps()
> 'Application.ScreenUpdating = False
> Dim ws1 As Worksheet
> Dim wsNew As Worksheet
> Dim rng As Range
> Dim R As Integer
> Dim c As Range
> Set ws1 = Sheets("PCT Specific Data")
> Set rng = Range("Database")
>
> 'extract a list of PCTs
> ws1.Columns("H:H").AdvancedFilter _
> Action:=xlFilterCopy, _
> CopyToRange:=Range("BA1"), Unique:=True
> R = Cells(Rows.Count, "BA").End(xlUp).Row
>
> 'set up Criteria Area
> Range("BC1").Value = Range("H1").Value
> While R < 301
> Wend
> For Each c In Range("BA2:BA300")
> 'For Each c In Range("BA2:BA" & r)
> 'add the rep name to the criteria area
> ws1.Range("BC2").Value = c.Value
> 'add new sheet and run advanced filter
> Set wsNew = Sheets.Add
> wsNew.Move After:=Worksheets(Worksheets.Count)
> wsNew.Name = c.Value
> rng.AdvancedFilter Action:=xlFilterCopy, _
> CriteriaRange:=Sheets("PCT Specific Data").Range("BC1:BC2"), _
> CopyToRange:=wsNew.Range("A1"), _
> Unique:=False
> Next
> ws1.Select
> ws1.Columns("BA:BC").Delete
> 'Application.ScreenUpdating = True
> End Sub
>
>
> --
> AmyTaylor
> ------------------------------------------------------------------------
> AmyTaylor's Profile: http://www.excelforum.com/member.php...o&userid=20970
> View this thread: http://www.excelforum.com/showthread...hreadid=537134
>
>