Can someone help me with this macro please?

Scenario:
Table of Contents Sheet named TOC
Table of Contents range A6:D9
Template Sheet named template

Macro:
1) Create new worksheet from worksheet template for each value in
column A
2) Name the worksheet with the A value from range
3) New worksheet cell D1 equals corresponding D value from range

Give this a shot:
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(Befo=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

Regards,
Ryan---


"CJ" wrote:

Can someone help me with this macro please?

Scenario:
Table of Contents Sheet named TOC
Table of Contents range A6:D9
Template Sheet named template

Macro:
1) Create new worksheet from worksheet template for each value in
column A
2) Name the worksheet with the A value from range
3) New worksheet cell D1 equals corresponding D value from range

Thanks... it didn't work for what I needed..

I ended up with this that works:
However it doesn't do the step 3 I wanted... can you help with that?

Sub CreateSheets()
Dim rng As Range, rngNames As Range
Dim szSheetName As String
Dim wks As Worksheet

'Turn off the screen
Application.ScreenUpdating = False

'Get the list of names
With ThisWorkbook.Worksheets("TOC")
Set rngNames = .Range(.Range("A6"), .Range("A6").End(xlDown))
End With

'Loop through the list of names
For Each rng In rngNames
'Store the name for the worksheet
szSheetName = Left$(rng.Text, 31)

'See if the sheet already exists
On Error Resume Next 'Suppress an error if sheet not found
Set wks = Nothing
Set wks = ThisWorkbook.Worksheets(szSheetName)
On Error GoTo 0

'If it doesn't exist, create it
If wks Is Nothing Then
ThisWorkbook.Worksheets("template").Copy
Befo=ThisWorkbook.Worksheets("template")
ActiveSheet.Name = szSheetName
End If
Next rng

End Sub

I'm not sure what you mean by this:
'New worksheet cell D1 equals corresponding D value from range'
If you send me an email, with a little more detail of what you want, I'll
try to do it for you.


Regards,
Ryan--


"CJ" wrote:

Thanks... it didn't work for what I needed..

I ended up with this that works:
However it doesn't do the step 3 I wanted... can you help with that?

Sub CreateSheets()
Dim rng As Range, rngNames As Range
Dim szSheetName As String
Dim wks As Worksheet

'Turn off the screen
Application.ScreenUpdating = False

'Get the list of names
With ThisWorkbook.Worksheets("TOC")
Set rngNames = .Range(.Range("A6"), .Range("A6").End(xlDown))
End With

'Loop through the list of names
For Each rng In rngNames
'Store the name for the worksheet
szSheetName = Left$(rng.Text, 31)

'See if the sheet already exists
On Error Resume Next 'Suppress an error if sheet not found
Set wks = Nothing
Set wks = ThisWorkbook.Worksheets(szSheetName)
On Error GoTo 0

'If it doesn't exist, create it
If wks Is Nothing Then
ThisWorkbook.Worksheets("template").Copy
Befo=ThisWorkbook.Worksheets("template")
ActiveSheet.Name = szSheetName
End If
Next rng

End Sub

Sorry to take it offline, but I couldnt understand the issue at hand. The
problem was resolved with two macros:

€˜This macro creates a new sheet for every item in the chosen Column,
'and copies the data that matches the values in the chosen column€¦
'it uses Excels AutoFilter tool.
Sub ExportDatabaseToSeparateSheets()
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 = Range("A6").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(Befo=Worksheets(1))

mySht.Name = myCell.Value
On Error Resume Next
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


€˜This macro copies the values in each cell D1 in each sheet,
'and pastes all values in column B, staring in B6 on the TOC sheet
Sub CopyD1()
Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range
Set rDest = ActiveWorkbook.Worksheets("TOC").Range("B6")
For Each ws In ActiveWorkbook.Worksheets
If ws.Name < "TOC" And ws.Name < "template" And ws.Name <
"list" Then
rDest.Offset(0, -1).Value = ws.Name
With ws.Range("D1")
rDest.Resize(1, .Columns.Count).Value = .Value
End With
Set rDest = rDest.Offset(1, 0)
End If
Next ws
End Sub


Ryan---

--
RyGuy


"RyGuy" wrote:

I'm not sure what you mean by this:
'New worksheet cell D1 equals corresponding D value from range'
If you send me an email, with a little more detail of what you want, I'll
try to do it for you.


Regards,
Ryan--


"CJ" wrote:

Thanks... it didn't work for what I needed..

I ended up with this that works:
However it doesn't do the step 3 I wanted... can you help with that?

Sub CreateSheets()
Dim rng As Range, rngNames As Range
Dim szSheetName As String
Dim wks As Worksheet

'Turn off the screen
Application.ScreenUpdating = False

'Get the list of names
With ThisWorkbook.Worksheets("TOC")
Set rngNames = .Range(.Range("A6"), .Range("A6").End(xlDown))
End With

'Loop through the list of names
For Each rng In rngNames
'Store the name for the worksheet
szSheetName = Left$(rng.Text, 31)

'See if the sheet already exists
On Error Resume Next 'Suppress an error if sheet not found
Set wks = Nothing
Set wks = ThisWorkbook.Worksheets(szSheetName)
On Error GoTo 0

'If it doesn't exist, create it
If wks Is Nothing Then
ThisWorkbook.Worksheets("template").Copy
Befo=ThisWorkbook.Worksheets("template")
ActiveSheet.Name = szSheetName
End If
Next rng

End Sub

Thanks RyGuy...

I had to modify it a tad... I was getting a circular reference
error...

Here is what works for me:

Sub CreateSheets()
Dim rng As Range, rngNames As Range
Dim SheetName As String
Dim wks As Worksheet

'Turn off the screen
Application.ScreenUpdating = False

'Get the list of sheet names
With ThisWorkbook.Worksheets("TOC")
Set rngNames = .Range(.Range("A6"), .Range("A6").End(xlDown))
End With

'Loop through the list of sheet names
For Each rng In rngNames

'Store the name for the worksheet
SheetName = Left$(rng.Text, 31)

'See if the sheet already exists
On Error Resume Next 'Suppress an error if sheet not found
Set wks = Nothing
Set wks = ThisWorkbook.Worksheets(SheetName)
On Error GoTo 0

'If it doesn't exist, create it
If wks Is Nothing Then
'Copy the template sheet (which then becomes the active
sheet)
ThisWorkbook.Worksheets("template").Copy
Befo=ThisWorkbook.Worksheets("template")
'Name the copied sheet(which is now active). Sheet names
can only be 31 characters long
ActiveSheet.Name = SheetName

End If
Next rng

'Set Section Name
Dim ws As Worksheet
Dim rSection As Range
Set rSection = ActiveWorkbook.Worksheets("TOC").Range("B6")

For Each ws In ActiveWorkbook.Worksheets
If ws.Name < "TOC" And ws.Name < "template" And ws.Name
< "list" Then
rSection.Offset(0, -1).Value = ws.Name
With ws.Range("D1")
.Value = rSection.Resize(1, .Columns.Count).Value
End With
Set rSection = rSection.Offset(1, 0)
End If
Next ws
End Sub

Glad it worked for you. If it was indeed helpful, please click the 'yes'
button to indicate such.

Ryan---

--
RyGuy


"CJ" wrote:

Thanks RyGuy...

I had to modify it a tad... I was getting a circular reference
error...

Here is what works for me:

Sub CreateSheets()
Dim rng As Range, rngNames As Range
Dim SheetName As String
Dim wks As Worksheet

'Turn off the screen
Application.ScreenUpdating = False

'Get the list of sheet names
With ThisWorkbook.Worksheets("TOC")
Set rngNames = .Range(.Range("A6"), .Range("A6").End(xlDown))
End With

'Loop through the list of sheet names
For Each rng In rngNames

'Store the name for the worksheet
SheetName = Left$(rng.Text, 31)

'See if the sheet already exists
On Error Resume Next 'Suppress an error if sheet not found
Set wks = Nothing
Set wks = ThisWorkbook.Worksheets(SheetName)
On Error GoTo 0

'If it doesn't exist, create it
If wks Is Nothing Then
'Copy the template sheet (which then becomes the active
sheet)
ThisWorkbook.Worksheets("template").Copy
Befo=ThisWorkbook.Worksheets("template")
'Name the copied sheet(which is now active). Sheet names
can only be 31 characters long
ActiveSheet.Name = SheetName

End If
Next rng

'Set Section Name
Dim ws As Worksheet
Dim rSection As Range
Set rSection = ActiveWorkbook.Worksheets("TOC").Range("B6")

For Each ws In ActiveWorkbook.Worksheets
If ws.Name < "TOC" And ws.Name < "template" And ws.Name
< "list" Then
rSection.Offset(0, -1).Value = ws.Name
With ws.Range("D1")
.Value = rSection.Resize(1, .Columns.Count).Value
End With
Set rSection = rSection.Offset(1, 0)
End If
Next ws
End Sub