macro that can copy each persons’ info in a list to a auto-g

[Cosmos75]

From
http://www.mrexcel.com/board/viewtopic.php?topic=4847&forum=2

On 2002-04-16 12:26, Jay Petrulis wrote:

On 2002-04-16 11:05, Cosmos75 wrote:
I have a Worksheet with names (Column A) and info/values to the right (Columns B to E).

Each names appears more than once.

Is there a macro that can copy each persons’ info to a auto-generated sheet named after the person?

Hi,

Short answer:

1. Get a list of unique names and add a sheet, then name it the person's name

a) advanced filter and cycle through the list

b) loop through the list of names and determine whether the sheet exists or not. If it does, go on, else add the sheet.

2. Cycle through the data list and add each item to the appropriate sheet. You will match the name in the cell and transfer the data to the relevant sheet.

These two can/should be separate routines as you will only have to add sheets initially and/or when new people are added.

Here is a function (adapted from John W. Power Programming book) which can be called to determine if a sheet exists or not.

--------------------
Public Function SheetExists(sheetname) As Boolean
Dim abc As Object
On Error Resume Next
Set abc = ActiveWorkbook.Sheets(sheetname)
If Err = 0 Then SheetExists = True _
Else SheetExists = False
End Function
--------------------

This should get you started.

HTH,
Jay

 

[Cosmos75]

Here's what I have so far.

But it doesn't work totally right, I get the first name in my list twice, EVEN after using advanced filter. At least that's how it shows up after the macro runs. So my macro stops, and always give me an extra sheet that has no name (except the default one).

Sub CreateSheets()

'Makes sure that the status bar is visible
Application.DisplayStatusBar = True

'Enter message for status bar
Application.StatusBar = "Performing Task!! Please Wait!!"

'Turn off Screen updating
Application.ScreenUpdating = False

Range("A2", Range("A65536").End(xlUp).Address).Select
RowCounter = Selection.Count

NameRange = Range("A2", Range("A65536").End(xlUp).Address).Address


Range(NameRange).AdvancedFilter Action:=xlFilterInPlace, Unique:=True

Dim SheetName As String


For i = 2 To RowCounter + 1
Sheets("Names").Select
SheetName = Range("A" & i).Value
Sheets.Add
ActiveSheet.Select
ActiveSheet.Name = SheetName
Next i

ActiveSheet.ShowAllData



'Turn on Screen Updating
'(Happens automatically after a module is finished)
Application.ScreenUpdating = True

'Reset the Status Bar
Application.StatusBar = False

End Sub
This message was edited by Cosmos75 on 2002-04-16 15:37

 

[Jay Petrulis]

Hi,

Names on sheet "Names" beginning in A2 down the column.

Delete all sheets except for "Names" and run the Add_Names() macro below.

Then, run it again after finishing to test that duplicates sheets are not added.

Of course, save your work before doing all this.

------------------
Option Explicit
Public Function NameofSheet()
NameofSheet = Application.Caller.Parent.Name
End Function

Public Function SheetExists(sheetname) As Boolean
Dim abc As Object
On Error Resume Next
Set abc = ActiveWorkbook.Sheets(sheetname)
If Err = 0 Then SheetExists = True _
Else SheetExists = False
End Function

Sub Add_Sheets()
Dim lastrow As Long, sheettoname As String, x As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
lastrow = Sheets("Names").Cells(Rows.Count, 1).End(xlUp).Row

For x = 2 To lastrow
sheettoname = Sheets("Names").Cells(x, 1)
If SheetExists(sheettoname) = True Then
' do nothing
Else
Worksheets.Add After:=Sheets(ThisWorkbook.Worksheets.Count)
ActiveSheet.Name = Sheets("Names").Cells(x, 1).Value
End If
Next x
Sheets("Names").Select
MsgBox "Done!"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
----------------------

HTH,
Jay

 

[Cosmos75]

Thanks, Jay!

Now to try and tackle populating those named sheets with their respective namesakes info....

Any ideas on why mine doesn't work so well?
This message was edited by Cosmos75 on 2002-04-16 15:40

 

[Jay Petrulis]

In your Advanced Filter, start the NameRange at A1, not A2, and you will remove the duplicate first name. You will get the header, but you don't cycle through that when you add/name the sheets, so you should be OK there.

If I see anything else, I'll let you know.

I think writing the data to the sheets should be fairly straightforward from here.

I will look to see if there is anything else I can add.

Bye,
Jay

 

[Cosmos75]

The data should be OK.

Probably use something with the structure

If Cell.Value = ws.name Then
Sheets(ws.name).Cell("A1") = Cell.Value

use a loop or For i to ...

to go in and do it.

It'll be trial and error for me since I am not good at VBA. have to record macros and changes them use existing macros that I've learned.

THANKS!

 

[Cosmos75]

Got it to work! (with Help from Jay pointing out my mistake!) The creating sheets part, that is! Here's the code!

Sub CreateSheets()

'Makes sure that the status bar is visible
Application.DisplayStatusBar = True

'Enter message for status bar
Application.StatusBar = "Performing Task!! Please Wait!!"

'Turn off Screen updating
Application.ScreenUpdating = False




NameRange = Range("A1", Range("A65536").End(xlUp).Address).Address

Range(NameRange).AdvancedFilter Action:=xlFilterInPlace, Unique:=True



Range("A2", Range("A65536").End(xlUp).Address).Select
RowCounter = Selection.Count

Dim sheetname As String


For i = 2 To RowCounter + 1
Sheets("Names").Select
sheetname = Range("A" & i).Value
Sheets.Add
ActiveSheet.Select
ActiveSheet.Name = sheetname
Next i

Sheets("Names").Select

ActiveSheet.ShowAllData



'Turn on Screen Updating
'(Happens automatically after a module is finished)
Application.ScreenUpdating = True

'Reset the Status Bar
Application.StatusBar = False

End Sub

 

[Cosmos75]

Jay,

Would yours be faster than mine for a lot of sheets? Why would the faster one be the faster one? (hope that makes sense)

THANKS!

 

[Jay Petrulis]

Hard to say. I am looping through the entire range in column A, whereas you are only working with the unique elements, so yours should be faster on that front.

You should check, though, that you don't keep adding sheets if the macro is run again, or worse, throw an error. Only add the sheet if it doesn't already exist.

Your code jumps back and forth between worksheets. Delete the following line

ActiveSheet.Select

as it is not necessary and would speed it ever so slightly.

The speed differences should be negligible in any case. Writing to the worksheets shouldn't be slow either.

The one advantage of my approach would be to do something like the following pseudo code:

Loop through the names
if the sheet doesn't exist then
1) add it
2) copy the data to the next available row

if the sheet exists then
1) copy the data to the next available row

Only one pass through the data.

Also, if your Names sheet is also your data sheet, consider doing the following:

1. Adding new sheets (already done)
2. Looping through with Autofilter to isolate the names and associated data and copying all of it in one shot.

This is dependent on how you want your data to fall on the new sheet but would be very fast. I have coded like this before, but it would take a bit to find it.

Bye,
Jay

 

[Cosmos75]

Jay,

First of all, THANK YOU for all you help!!

For i = 2 To RowCounter + 1
Sheets("Names").Select
sheetname = Range("A" & i).Value
Sheets.Add
ActiveSheet.Select
ActiveSheet.Name = sheetname
Next i

Wouldn'e taking out ActiveSheet.Select make the sheet Names be the active one (since there is Sheets("Names").Select or does adding a sheet make the added sheet the active sheet?

On my way home, I realiased that looping could take awhile. Proably better to use autofilter and copy the data with the filter on each name. Although I am not sure how to loop through the names. Maybe something like

For Each ws in Worksheet
Sheets("Names"),Select
'Autofilter using ws.name and select. (Not sure of the code, will have to wait till I I get to work and have the use of Excel.
'Then copy back into the respective sheet
ws.select.paste
This message was edited by Cosmos75 on 2002-04-16 17:37