I want to split a data dump into multiple files.......

Posted by Dave on January 11, 2002 6:15 AM

Hi all.
When i output from our database, all the data comes out as one file. I would like to find a way to split the one file up into separate files depending on a value in column A.

ie.
A: B:
102924 Fred
102924 Joe
102924 Bob
104628 Black
104628 Blue
104628 Red
104628 Green
105227 Laura
105227 Louise

would idealy be split into three files (called 105227"originalfilename".xls,104268"originalfilename".xls and 102924"originalfilename".xls) each containing only data with the same value in column A. If you see what i mean. It's harder to explain than it should be!

Both the number of different values in A and the number of total records can vary, as will the original file name of the file i run the macro on so, they need to be variables i guess, but, i dont know what the code would be!

And hints, tip or code sugestions greatly appreciated!

Dave

Posted by Jerid on January 11, 2002 1:52 PM

Assuming that your data is in columns A & B with no empty cells from row 1 to the end of your data this will work for you.

Public Sub SplitSheet()
Dim CurNum As String
Dim sControlBook As String
Dim sNewBook As String
Dim sNameArray() As String
Dim lCounter As Long
Dim lX As Long

'Collect the name of the current workbook
sControlBook = ActiveWorkbook.Name

'Sort the data
Columns("A:B").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

application.Range("A1").Select
application.SheetsInNewWorkbook = 1

'Start our work
Do While ActiveCell.Value &LT;&GT; vbNullString
CurNum = ActiveCell.Value
Workbooks.Add
ActiveWorkbook.SaveAs (CurNum & "_" & Left(sControlBook, InStr(1, sControlBook, ".") - 1))
sNewBook = ActiveWorkbook.Name
application.Range("A1").Select
Workbooks(sControlBook).Activate

'Houskeeping
lCounter = 0
ReDim sNameArray(lCounter)

'Collect Names
Do While ActiveCell.Value = CurNum
lCounter = lCounter + 1
ReDim Preserve sNameArray(lCounter)
sNameArray(lCounter) = ActiveCell.Offset(0, 1).Value
ActiveCell.Offset(1, 0).Select
Loop

'Write data to new Workbook
Workbooks(sNewBook).Activate
For lX = 1 To UBound(sNameArray)
ActiveCell.Value = CurNum
ActiveCell.Offset(0, 1).Value = sNameArray(lX)
ActiveCell.Offset(1, 0).Select
Next lX

Workbooks(sNewBook).Close True
Workbooks(sControlBook).Activate

Loop
End Sub

Posted by Dave on January 14, 2002 1:26 AM

Thanks, But one more thing.......

Excelent!
That worked great but, how do i extend it to include more columns (up to "CL") as my data is that long?
i've got the sort bit sorted out but, cant see how to modify the next bit...
Thanks for your help,
Dave 'Collect the name of the current workbook sControlBook = ActiveWorkbook.Name 'Sort the data Columns("A:B").Select Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom application.Range("A1").Select application.SheetsInNewWorkbook = 1 'Start our work Do While ActiveCell.Value &LT;&GT; vbNullString CurNum = ActiveCell.Value Workbooks.Add ActiveWorkbook.SaveAs (CurNum & "_" & Left(sControlBook, InStr(1, sControlBook, ".") - 1)) sNewBook = ActiveWorkbook.Name application.Range("A1").Select Workbooks(sControlBook).Activate 'Houskeeping lCounter = 0 ReDim sNameArray(lCounter) 'Collect Names Do While ActiveCell.Value = CurNum lCounter = lCounter + 1 ReDim Preserve sNameArray(lCounter) sNameArray(lCounter) = ActiveCell.Offset(0, 1).Value ActiveCell.Offset(1, 0).Select Loop 'Write data to new Workbook Workbooks(sNewBook).Activate For lX = 1 To UBound(sNameArray) ActiveCell.Value = CurNum ActiveCell.Offset(0, 1).Value = sNameArray(lX) ActiveCell.Offset(1, 0).Select Next lX Workbooks(sNewBook).Close True Workbooks(sControlBook).Activate