Add worksheets based on cell value

C

cougarman

I have a single worksheet workbook that contains client names in column
A, and associated data in the other columns. There are multiple
records (rows) for each client. Is it possible to use a macro or VB
script to scan column A, and move all records associated with each
client to a new worksheet (and change the worksheet name to the
client's name)?
 
D

Dave Peterson

Debra Dalgleish and Ron de Bruin have samples that you may like. Ron's addin
may be sufficient right out of the box.

Debra's site:
http://www.contextures.com/excelfiles.html

Create New Sheets from Filtered List -- uses an Advanced Filter to create
separate sheet of orders for each sales rep visible in a filtered list; macro
automates the filter. AdvFilterRepFiltered.xls 35 kb

or

Update Sheets from Master -- uses an Advanced Filter to send data from
Master sheet to individual worksheets -- replaces old data with current.
AdvFilterCity.xls 55 kb

And Ron de Bruin's easyfilter.
http://www.rondebruin.nl/easyfilter.htm

If you're new to macros, you may want to read David McRitchie's intro at:
http://www.mvps.org/dmcritchie/excel/getstarted.htm
 
C

cougarman

Thank you Dave! I will be reviewing these links as time permits
today. I appreciate your feedback.
 
C

cougarman

Dave -

I copied Debra Dalgleish's code, and experimented with it. It appears
that only the first 7 columns of data get copied to the new worksheets.
If I run the code against 9 columns, it doesn't move the last 2
columns. Any idea why?
 
D

Dave Peterson

Depending on what code you used...

Debra has a line like this that defines the range to be copied:

Set rng = Range("Database")

Database is a range that's exactly 7 columns wide.

You could use Insert|name|define to change that range.

But you have to be careful. Debra's code uses column J and L for storing the
unique values in the list. You may want to move them way over to the far right
(IU & IV???).

I looked at:
Create New Sheets from Filtered List
from Deb's site.
 
C

cougarman

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. ???
 
D

Dave Peterson

You may want to look at Ron de Bruin's code:
Hi

On this page there is a example for workbooks also
http://www.rondebruin.nl/copy5.htm
Click to expand...

(Ron posted this very recently to a very similar question.)

or you could try this change to Debra's code:

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:=Range("L1")

ws1.Columns("L:L").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=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
'add new sheet (if required)
'and run advanced filter

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
 
D

Dave Peterson

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
 
Top