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]

Any suggestions on improving this?

Working 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

Dim NameRange As String

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
Dim Exists As Boolean

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

For Each ws In Sheets
If ws.Name = sheetname Then
Exists = True
If Exists = True Then GoTo StartAgain:
End If
Next ws

Sheets.Add
ActiveSheet.Select
ActiveSheet.Name = sheetname

StartAgain:
Next i

Sheets("Names").Select

ActiveSheet.ShowAllData

'Turn On Autofilter
Columns("A:D").Select
Selection.AutoFilter

For Each ws In Sheets

If ws.Name <> "Names" Then

Selection.AutoFilter Field:=1, Criteria1:=ws.Name
Range("A1").Select

'This makes the range A1 to
'Edge of range that would contain all data even if that cell is empty
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
ws.Paste

End If

Next ws

'Turn Off Autofilter
Columns("A:D").Select
Selection.AutoFilter

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

'Reset the Status Bar
Application.StatusBar = False

End Sub

 

[Cosmos75]

Sorry for the long pages or code, people!!

 

[Jay Petrulis]

Some code rewritten. Posted without the comments.

General notes:
1. Variables are declared (Dim) at the top of the module.
2. The Exists code is removed because you don't need to test a condition and assign it to a variable, then test the variable here.
3. Avoid .Select unless it is necessary. (e.g. when you add a sheet, the sheet automatically becomes the active sheet, no need to select)

---------------
Sub CreateSheets()
Dim sheetname As String
Dim NameRange As String

Application.DisplayStatusBar = True
Application.StatusBar = "Performing Task!! Please Wait!!"
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

For i = 2 To RowCounter + 1
Sheets("Names").Select
sheetname = Range("A" & i).Value
For Each ws In Sheets
If ws.Name = sheetname Then GoTo StartAgain
Next ws
Sheets.Add
ActiveSheet.Name = sheetname
StartAgain:
Next i
Sheets("Names").Select
ActiveSheet.ShowAllData
Columns("A:D").AutoFilter
For Each ws In Sheets
If ws.Name <> "Names" Then
[A1].AutoFilter Field:=1, Criteria1:=ws.Name
Range("A1", Cells(1, 1).SpecialCells(xlLastCell)).Copy
ws.Paste
End If
Next ws
Columns("A:D").AutoFilter
Application.ScreenUpdating = True
Application.StatusBar = False

End Sub
--------------------------

Bye,
Jay

 

[Tommy Bak]

Sub AutoFilterModel()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim x, i As Long, a, y As Integer
Dim TempMatrix As Variant
x = Application.WorksheetFunction.CountA(Range("A:A"))
ReDim matrix(x)
ReDim TempMatrix(x, 1)
a = 0
TempMatrix = Range("A1:A" & x).Value
For i = 2 To x
If TempMatrix(i, 1) <> TempMatrix(i - 1, 1) Then
a = a + 1
matrix(a) = TempMatrix(i, 1)
End If
Next i
StartSheet = ActiveSheet.Name
For y = 1 To a
Selection.AutoFilter Field:=1, Criteria1:=matrix
Selection.CurrentRegion.Copy
Sheets.Add
ActiveSheet.Name = matrix
Range("A1").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
Sheets(StartSheet).Select
Next
Selection.AutoFilter
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

regards Tommy