Create new worksheet from exisitng data

[JayL]

All -
I receive a monthly text file I import to Excel.
Column A represents a specific location by code - usually 3 digits with
numerous entries (rows) for each location code. I usually sort by Col A and
cut and paste all the same Col A rows into a new worksheet, thus creating a
new worksheet for each location code. Each worksheet would ideally be named
the location code.

There is potentially 20 or 30 worksheets - which is time consuming to create
manually.
Is there a way to automate this?

TIA
-Jay

 

[Bernie Deitrick]

Jay,

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. Since the key ID
values are in column A, and column A must be the first column of the
database,
enter a 1 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

'Optional section to export the sheets to separate files
'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

 

[JayL]

Bernie - Thanks! Works great on the first location code but as soon as it
hits the second location code I get and error "1004" cannot rename sheet to
same name as another. I think it is seeing row 3 as another sheet. ???
here is a snipet of col A and B
Ideally I would have one sheet of all the '101's and one sheet of all the
'111's ...etc
101 8081010766
101 8081010766
101 8081010766
101 8081010766
101 8081010766
111 1111010766
111 1111010766
111 1111010766
111 1111010766
111 1111010766
111 1111010766
111 1111010766
111 1111010766

 

[Bernie Deitrick]

Jay,

The code was written for and tested on data that had strings for keys. Using
numbers requires that you change the line

myName = Worksheets(myCell.Value).Name

to

myName = Worksheets(CStr(myCell.Value)).Name

HTH,
Bernie
MS Excel MVP

 

[JayL]

Bernie -
Thanks! This is excellent!
-Jay

Jay,

The code was written for and tested on data that had strings for keys.
Using
numbers requires that you change the line

myName = Worksheets(myCell.Value).Name

to

myName = Worksheets(CStr(myCell.Value)).Name

HTH,
Bernie
MS Excel MVP

 

[Bernie Deitrick]

Jay,

You're welcome. Glad you liked it.

Bernie
MS Excel MVP

 

[LoboNetwork]

Hello bernie,

I used this code here however the saving of the sheets to separate files
didnt work. Any ideas or anything I need to enable?