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