A
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
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