separate into to worksheets

[Cindy]

I am using the subtotal feature under data to separate with a pagebreak
information. I need the information copied or broken in to separate
worksheets. Can this be done systematically there are about 350 sections I
need broken out.

 

[Bernie Deitrick]

Cindy,

You can run a macro to do this: take off the subtotals prior to running it.

HTH,
Bernie
MS Excel MVP

Sub ExportDatabaseToSeparateSheets()
'Export is based on the value in the desired column
Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range
Dim myShtName As String
Dim KeyCol As Integer

myShtName = ActiveSheet.Name
KeyCol = InputBox("What column # within database to use as key?")

Set myArea = ActiveCell.CurrentRegion.Columns(KeyCol).Offset(1, 0).Cells

Set myArea = myArea.Resize(myArea.Rows.Count - 1, 1)

For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(before:=Worksheets(1))
mySht.Name = myCell.Value
With myCell.CurrentRegion
.AutoFilter Field:=KeyCol, Criteria1:=myCell.Value
.SpecialCells(xlCellTypeVisible).Copy _
mySht.Range("A1")
mySht.Cells.EntireColumn.AutoFit
.AutoFilter
End With
Resume
SheetExists:
Next myCell

End Sub

 

[Cindy]

Bernie,

Can this also be done but break out into separate workbooks?

 

[Bernie Deitrick]

Cindy,

Yes.

Copy the macro below and put it into a codemodule of either your
personal.xls or of the workbook with the database.

Select a single cell in your database and run the macro. If the key ID
values are in column C, and column C is the second column of the database,
then enter a 2 when asked "What column # within database to use as key?"

The files will be saved to whatever folder is currently the default folder,
though that is easy to modify.

HTH,
Bernie
MS Excel MVP

Sub ExportDatabaseToSeparateFiles()
'Export is based on the value in the desired column
Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range
Dim myShtName As String
Dim KeyCol As Integer

myShtName = ActiveSheet.Name
KeyCol = InputBox("What column # within database to use as key?")


Set myArea = ActiveCell.CurrentRegion.Columns(KeyCol).Offset(1, 0).Cells

Set myArea = myArea.Resize(myArea.Rows.Count - 1, 1)

For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(before:=Worksheets(1))
mySht.Name = myCell.Value
With myCell.CurrentRegion
.AutoFilter Field:=KeyCol, Criteria1:=myCell.Value
.SpecialCells(xlCellTypeVisible).Copy _
mySht.Range("A1")
mySht.Cells.EntireColumn.AutoFit
.AutoFilter
End With
Resume
SheetExists:
Next myCell

For Each mySht In ActiveWorkbook.Worksheets
If mySht.Name = myShtName Then
Exit Sub
Else
mySht.Move
ActiveWorkbook.SaveAs "Workbook " & ActiveSheet.Name & ".xls"
ActiveWorkbook.Close
End If
Next mySht
End Sub

 

[Cindy]

Thanks, this is awesome.

Cindy,

Yes.

Copy the macro below and put it into a codemodule of either your
personal.xls or of the workbook with the database.

Select a single cell in your database and run the macro. If the key ID
values are in column C, and column C is the second column of the database,
then enter a 2 when asked "What column # within database to use as key?"

The files will be saved to whatever folder is currently the default folder,
though that is easy to modify.

HTH,
Bernie
MS Excel MVP

Sub ExportDatabaseToSeparateFiles()
'Export is based on the value in the desired column
Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range
Dim myShtName As String
Dim KeyCol As Integer

myShtName = ActiveSheet.Name
KeyCol = InputBox("What column # within database to use as key?")


Set myArea = ActiveCell.CurrentRegion.Columns(KeyCol).Offset(1, 0).Cells

Set myArea = myArea.Resize(myArea.Rows.Count - 1, 1)

For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(before:=Worksheets(1))
mySht.Name = myCell.Value
With myCell.CurrentRegion
.AutoFilter Field:=KeyCol, Criteria1:=myCell.Value
.SpecialCells(xlCellTypeVisible).Copy _
mySht.Range("A1")
mySht.Cells.EntireColumn.AutoFit
.AutoFilter
End With
Resume
SheetExists:
Next myCell

For Each mySht In ActiveWorkbook.Worksheets
If mySht.Name = myShtName Then
Exit Sub
Else
mySht.Move
ActiveWorkbook.SaveAs "Workbook " & ActiveSheet.Name & ".xls"
ActiveWorkbook.Close
End If
Next mySht
End Sub