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.

Split data into new sheets
 

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

Split data into new sheets
 

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

Split data into new sheets
 

Hi bernard

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



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


"bernard" wrote in message ...
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.

Split data into new sheets
 

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" wrote in message ...
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.