Group into sheets

[gdspeare]

I have data in a worksheet sorted by column H. I would like to have all similar rows pasted in a new sheet named with the appropriate group name


Help,

thanks

 

[erik.van.geit]

gdspeare,
can you clarify this ?
an example would help

kind regards,
Erik

 

[oddworld]

re

Hi gdspeare if i understand what you want, I have created a sheet for my local swimming club. i enter their names and results in and i then run the following code, it will copy the date to a new sheet and name the sheet to what the name in column "a" is. it will group the last names together on the one sheet. I have also added something like everytime i run the code it will delete all the data except for the "0summary-sheet"
just change the sheet names and ranges to suit your needs.

Sub CreateSheets()

With Worksheets("0summary")
For I = .Range("a65536").End(xlUp).Row To 2 Step -1

If Not SheetExists(.Cells(I, 1).Value) Then

'COPY SHEET
Worksheets.Add After:=Worksheets(Sheets.Count)
ActiveSheet.Name = .Cells(I, 1).Value

'COPY HEADER
.Range("A1:Z1").Copy
ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")

End If

Next I
.Activate
.Range("a1").Select
Application.CutCopyMode = False
End With
End Sub

Private Function SheetExists(sname) As Boolean
' Returns TRUE if sheet exists in the active workbook
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(sname)
If Err = 0 Then SheetExists = True _
Else: SheetExists = False
End Function



Sub deletesheet()
Dim I As Integer
Dim vrtsheet As Variant
Dim question As Boolean
For Each vrtsheet In Worksheets
question = False
For I = Range("a65536").End(xlUp).Row To 2 Step -1
If vrtsheet.Name = Worksheets("0summary").Cells(I, 1).Value Or vrtsheet.Name = "0summary" Then
question = True
End If

Next I
If question = False Then
Application.DisplayAlerts = False
vrtsheet.Delete
Application.DisplayAlerts = True
End If

Next vrtsheet

Worksheets("0summary").Activate
Worksheets("0summary").Range("a1").Select
End Sub

Sub copydata()

Dim I As Integer
Dim vrtsheet As Variant

For Each vrtsheet In Worksheets
If vrtsheet.Name <> "0summary" Then
vrtsheet.Range("a2:z10").ClearContents

End If

Next vrtsheet

For I = Range("A65536").End(xlUp).Row To 2 Step -1
If Cells(I, 1).Value <> " " Then
Rows(I).Copy Destination:=Sheets(Cells(I, 1).Value).Range("a65536").End(xlUp).Offset(1, 0)



End If

Next I
Worksheets("0summary").Activate
Worksheets("0summary").Range("a1").Select
End Sub



Sub SortSheets()
Dim I As Integer, J As Integer
For I = 1 To Sheets.Count
For J = 1 To I - 1
If UCase(Sheets(I).Name) < UCase(Sheets(J).Name) Then
Sheets(I).Move before:=Sheets(J)
Exit For
End If
Next J
Next I
Worksheets("0summary").Activate
Worksheets("0summary").Range("a1").Select
End Sub


I then run the code of a button like this


Sub Macro4()
'
' Macro4 Macro
'
'

'
Application.Run "'swim test.xls'!ThisWorkbook.CreateSheets"
Application.Run "'swim test.xls'!ThisWorkbook.copydata"
Application.Run "'swim test.xls'!ThisWorkbook.deletesheet"
Application.Run "'swim test.xls'!ThisWorkbook.SortSheets"
End Sub



cheers