Add worksheets based on cell value
I had some unqualified ranges:
Option Explicit
Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")
'extract a list of Sales Reps
ws1.Columns("C:C").Copy _
Destination:=ws1.Range("L1")
ws1.Columns("L:L").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=ws1.Range("J1"), Unique:=True
r = ws1.Cells(ws1.Rows.Count, "J").End(xlUp).Row
'set up Criteria Area
ws1.Range("L1").Value = ws1.Range("C1").Value
For Each c In ws1.Range("J2:J" & r)
'add the rep name to the criteria area
ws1.Range("L2").Value = c.Value
Set wsNew = Workbooks.Add(1).Worksheets(1)
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ws1.Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Next
ws1.Parent.Activate
ws1.Select
ws1.Columns("J:L").Delete
End Sub
cougarman wrote:
Thanks Dave! It's working pretty well for me. Baby steps...baby
steps....
Now wondering how to create new workbook(s) for each client value. ???
--
Dave Peterson
|