Macro to insert new sheets and copy information.

  • Thread starter Thread starter Paul
  • Start date Start date
P

Paul

Hi

I receive a huge xls file on a monthly basis. Column A is used for ID
nr only, and is always sorted.

Question: is it possible to make a macro that instert a new sheet for
each change in ID nr, and that also copy all rows with identical ID nr
to the new sheet?

Example:
Workbookname Transactions.xls
Sheet used: Januar
"Picture" of the sheet named Januar
ROW NR COLUMN A COLUMN B
1 ID NR Text
2 1 a
3 1 b
4 1 c
5 2 d
6 2 e
7 3 f
8 3 g
9 3 h


The macro should insert three new sheets named 1, 2 and 3.

"Picture" of the sheet named 1
ROW R COLUMN A COLUMN B
1 1 a
2 1 b
3 1 c


"Picture" of the sheet named 2
ROW R COLUMN A COLUMN B
1 2 d
2 2 e

"Picture" of the sheet named 3
ROW R COLUMN A COLUMN B
1 3 f
2 3 g
3 3 h

Regards,
Paul
 
Paul,

This wil do it:

Sub SplitData()
Const ID_Column As Integer = 1
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lRow As Long, lLen As Long
Dim strID As String

Application.ScreenUpdating = False

Set wsSource = ActiveSheet
lRow = 2

Do
lLen = 1

strID = wsSource.Cells(lRow, ID_Column).Formula
Do While wsSource.Cells(lRow + lLen,
ID_Column).Formula = strID _
And wsSource.Cells(lRow + lLen, ID_Column).Formula
<> ""
lLen = lLen + 1
Loop

Set wsTarget = Worksheets.Add
wsTarget.Name = strID
wsSource.Rows(lRow & ":" & lRow + lLen - 1).Copy _
Destination:=wsTarget.Range("A1")

lRow = lRow + lLen
Loop While wsSource.Cells(lRow, ID_Column).Formula <> ""

Application.ScreenUpdating = True
End Sub

Have the data sheet active, then run the macro.

Cheers,
Dave.
 
WOW :)

you saved a lot of work; I'm impressed!

Is it aslo possible to make another macro that also create new xls
files for each change in the ID number?

Thx in advance.

Regards,
Paul
 
With a slight mod, yes...

Sub SplitData_ToFiles()
'ID colum to define split. Must be grouped by this column
Const ID_Column As Integer = 1
'Folder in which to save files (must end in \)
Const BaseFolder As String = "C:\SYS\"
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lRow As Long, lLen As Long
Dim strID As String

Application.ScreenUpdating = False

Set wsSource = ActiveSheet
lRow = 2

Do
lLen = 1

strID = wsSource.Cells(lRow, ID_Column).Formula
Do While wsSource.Cells(lRow + lLen,
ID_Column).Formula = strID _
And wsSource.Cells(lRow + lLen, ID_Column).Formula
<> ""
lLen = lLen + 1
Loop

'create new workbook
Set wsTarget = Workbooks.Add.Sheets(1)
wsTarget.Name = strID
wsSource.Rows(lRow & ":" & lRow + lLen - 1).Copy _
Destination:=wsTarget.Range("A1")
'save and close
wsTarget.Parent.SaveAs BaseFolder & strID & ".xls"
wsTarget.Parent.Close savechanges:=False

lRow = lRow + lLen
Loop While wsSource.Cells(lRow, ID_Column).Formula <> ""

Application.ScreenUpdating = True
End Sub

If you want it is possible to make this 'flashier'- e.g.
prompt the user to choose a destination folder etc, or
have a status comment in the status bar..

Cheers,
Dave.
 
Dave Ramage said:
With a slight mod, yes...

Sub SplitData_ToFiles()
'ID colum to define split. Must be sorted by this column
Const ID_Column As Integer = 9
'Folder in which to save files (must end in \)
Const BaseFolder As String = "C:\TEMP\"
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lRow As Long, lLen As Long
Dim strID As String
Click to expand...

---- Lots of code & words snipped out.... ----

Dave - It's amazing that you posted this code on the same day I was
looking for exactly the same thing! I find that figuring things out
in VBA is much easier with examples like yours. Thanks. I have an
additional question. I would like there to be a cover sheet in the
new table. I can set one up manually in the source workbook but I
have not been able to copy it into the new workbook. Can you fit that
into your example? --

Thanks - dg
 
Back
Top