Split data into new sheets

I have a (very) long list, sorted by account code. I would like to write a
macro that splits the list into separate sheets in the workbook, with a
separate sheet for each account code.

Ideally, I would also like to rename each sheet to show which account code
the sheet contains.

I have no idea, though, where to start. Any ideas? Thanks in advance.

Hi bernard

How many different accounts are in the list (more or less than 250)???

below some code that I use to split files by account numbers where the
user has to select a cell within the column that contains the account
number...

Hope this helps

Regards

Papparotti

Dim bSh As Worksheet 'original sheet -> baseSheet
Dim AccCol As Integer 'column containing the account number
Dim maxRows As Integer
Dim maxCols As Integer
Dim i As Integer
Dim tmpName As String
Dim tmpName2 As String

Application.ScreenUpdating = False

AccCol = ActiveCell.Column

Set bSh = ActiveSheet
maxRows = bSh.UsedRange.Rows.Count - 1
maxCols = bSh.UsedRange.Columns.Count

For i = maxRows To 8 Step -1 'The copy process starts with the
last line

tmpName = Cells(i, AccCol).Text
tmpName2 = Cells(i, NameCol).Text

If Not findSheet(tmpName) Then 'The code for findSheet is
below!

Worksheets.Add
after:=Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Name = tmpName
ActiveSheet.Cells.Interior.Color = RGB(255, 255, 255)
'The following lines copy header information to the newly
created sheet
bSh.Activate
bSh.Range(Cells(1, 1), Cells(7, maxCols + 1)).Copy 'AMEND
TO FIT FILE
Worksheets(tmpName).Activate
ActiveSheet.Cells(1, 1).PasteSpecial (xlAll)
'end of header copying
End If

bSh.Activate

Cells(i, 2).EntireRow.Select
Selection.Copy
Worksheets(tmpName).Activate
Rows("8:8").Select 'you'll have to amend this
according to your headers
Selection.Insert Shift:=xlDown

bSh.Activate
Next i


Application.ScreenUpdating = True

End Sub

Private Function findSheet(ByVal sName As String) As Boolean
Dim s As Variant
For Each s In ActiveWorkbook.Worksheets
If s.Name = sName Then
findSheet = True
Exit Function
End If
Next s
findSheet = False
End Function

Thanks for this - I think I can see what this is doing (I am still at the
very early stages with VB!) but I can't quite get it to work. For example,
Visual Basic has hilgihted the following line in red:
'after:=Worksheets(ActiveWorkbook.Worksheets.Count)'. Any ideas?

Don't know if it helps at all, but my spreadsheet has 3 columns - Code,
Description and Amount and the header row is in line 4.

Thanks again.

"Papparotti" wrote:

> Hi bernard
>
> How many different accounts are in the list (more or less than 250)???
>
> below some code that I use to split files by account numbers where the
> user has to select a cell within the column that contains the account
> number...
>
> Hope this helps
>
> Regards
>
> Papparotti
>
> Dim bSh As Worksheet 'original sheet -> baseSheet
> Dim AccCol As Integer 'column containing the account number
> Dim maxRows As Integer
> Dim maxCols As Integer
> Dim i As Integer
> Dim tmpName As String
> Dim tmpName2 As String
>
> Application.ScreenUpdating = False
>
> AccCol = ActiveCell.Column
>
> Set bSh = ActiveSheet
> maxRows = bSh.UsedRange.Rows.Count - 1
> maxCols = bSh.UsedRange.Columns.Count
>
> For i = maxRows To 8 Step -1 'The copy process starts with the
> last line
>
> tmpName = Cells(i, AccCol).Text
> tmpName2 = Cells(i, NameCol).Text
>
> If Not findSheet(tmpName) Then 'The code for findSheet is
> below!
>
> Worksheets.Add
> after:=Worksheets(ActiveWorkbook.Worksheets.Count)
> ActiveSheet.Name = tmpName
> ActiveSheet.Cells.Interior.Color = RGB(255, 255, 255)
> 'The following lines copy header information to the newly
> created sheet
> bSh.Activate
> bSh.Range(Cells(1, 1), Cells(7, maxCols + 1)).Copy 'AMEND
> TO FIT FILE
> Worksheets(tmpName).Activate
> ActiveSheet.Cells(1, 1).PasteSpecial (xlAll)
> 'end of header copying
> End If
>
> bSh.Activate
>
> Cells(i, 2).EntireRow.Select
> Selection.Copy
> Worksheets(tmpName).Activate
> Rows("8:8").Select 'you'll have to amend this
> according to your headers
> Selection.Insert Shift:=xlDown
>
> bSh.Activate
> Next i
>
>
> Application.ScreenUpdating = True
>
> End Sub
>
> Private Function findSheet(ByVal sName As String) As Boolean
> Dim s As Variant
> For Each s In ActiveWorkbook.Worksheets
> If s.Name = sName Then
> findSheet = True
> Exit Function
> End If
> Next s
> findSheet = False
> End Function
>
>

Hi bernard

Look here
http://www.rondebruin.nl/copy5.htm



--
Regards Ron de Bruin
http://www.rondebruin.nl


"bernard" <[email protected]> wrote in message news:[email protected]...
>I have a (very) long list, sorted by account code. I would like to write a
> macro that splits the list into separate sheets in the workbook, with a
> separate sheet for each account code.
>
> Ideally, I would also like to rename each sheet to show which account code
> the sheet contains.
>
> I have no idea, though, where to start. Any ideas? Thanks in advance.

Ron

It works a treat! Thanks!

Bernard

"Ron de Bruin" wrote:

> Hi bernard
>
> Look here
> http://www.rondebruin.nl/copy5.htm
>
>
>
> --
> Regards Ron de Bruin
> http://www.rondebruin.nl
>
>
> "bernard" <[email protected]> wrote in message news:[email protected]...
> >I have a (very) long list, sorted by account code. I would like to write a
> > macro that splits the list into separate sheets in the workbook, with a
> > separate sheet for each account code.
> >
> > Ideally, I would also like to rename each sheet to show which account code
> > the sheet contains.
> >
> > I have no idea, though, where to start. Any ideas? Thanks in advance.
>
>
>