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

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