Pointer required

[KiwiBrian]

I have a 2000 row database with one of the columns containing an index
number between 1 and
30.
This is to enable the extraction of all records having the same index number
into 30 seperate files.
I assume that what I want to find/aquire/write is a script that will enable
the automatic (in one operation) extraction of the 30 different
mini-databases, saving them in the same folder as the source, and named
1.xls to 30.xls.
Can anyone give me any pointers as to how I might achieve my end objective?
Thanks
Brian Tozer

 

[Don Lloyd]

Hi Brian,

The following code has been drafted without knowledge of your database
layout.
It will work with the following provisions:-

1. That your database is sorted by Index Number
2. That you have a blank worksheet available in your database file
3. That you enter your details for the variables as indicated.

Sub Test()
Dim Indx, IndxCol, DestCell, RwFirst, RwLast, Blank
Dim CurrRw, Rnge As Range, Fname

'DATA RELATING TO YOUR DATA BASE - CHANGE ACCORDINGLY
RwFirst = 10 'Change to first row containing your data
IndxCol = 4 'Change to the column with your Index
DestCell = "A1" 'where the copied data is to be placed
Blank = 2 'The index (from left)of a blank worksheet
'
Application.ScreenUpdating = False
Indx = 0: CurrRw = RwFirst
RwLast = RwFirst
Do
Indx = Indx + 1
Do Until Cells(CurrRw + 1, IndxCol) <> Indx
RwLast = RwLast + 1
CurrRw = CurrRw + 1
Loop
Set Rnge = Range(Cells(RwFirst, 1), Cells(RwLast, 10))
'copy to the second sheet of master file
Rnge.Copy Sheets(Blank).Range(DestCell)
'this creates a new workbook
Sheets(Blank).Copy
Fname = Indx & ".xls"
ActiveWorkbook.SaveAs Filename:=Fname
ActiveWorkbook.Close
'now back to the master workbook
Sheets(Blank).Cells.ClearContents
RwFirst = RwLast + 1
Loop Until Indx = 3
Application.ScreenUpdating = True
'
End Sub

regards,
Don

 

[Don Lloyd]

Hi Brian,

My original post was OK for my tests but needs further modification to work
with your data.
The revised code is as follows.

Sub Test()
Dim Indx, IndxCol, DestCell, RwFirst, RwLast, Blank
Dim ColFirst, ColLast
Dim CurrRw, Rnge As Range, Fname

'DATA RELATING TO YOUR DATA BASE - CHANGE ACCORDINGLY
RwFirst = 10 'Change to first row containing your data
ColFirst = 3 'Change to first column of data
ColLast = 20 'change to last column of data
IndxCol = 4 'Change to the column with your Index
DestCell = "A1" 'where the copied data is to be placed
Blank = 2 'The index (from left)of a blank worksheet
'
Application.ScreenUpdating = False
Indx = 0: CurrRw = RwFirst
RwLast = RwFirst
Do
Indx = Indx + 1
Do Until Cells(CurrRw + 1, IndxCol) <> Indx
RwLast = RwLast + 1
CurrRw = CurrRw + 1
Loop
Set Rnge = Range(Cells(RwFirst, ColFirst), Cells(RwLast, ColLast))
'copy to the second sheet of master file
Rnge.Copy Sheets(Blank).Range(DestCell)
'this creates a new workbook
Sheets(Blank).Copy
Fname = Indx & ".xls"
ActiveWorkbook.SaveAs Filename:=Fname
ActiveWorkbook.Close
'now back to the master workbook
Sheets(Blank).Cells.ClearContents
RwFirst = RwLast + 1
Loop Until Indx = 3
Application.ScreenUpdating = True
'
End Sub

regards,
Don