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