Create New Sheets & Copy Specific Data To Each

Hi all,

I'm trying to put together a macro which will first create a new workbook sheet for each
cell which holds a value within a given range. The new sheets are named after each
cells value in the range. I got this part to work.

Next, I want to copy the cell values in each row of another sheet to one of the new sheets, if the value found in col. "B" of the other sheet matches the newly created sheets name. I think I might almost have it. I just need to figure a way to make it loop
through each row data for each new sheet that's been created.


Here a Step by Step "Logic" Flow Example:

Sheet 1. Range("S7").value = "Red
Sheet 1.Range("S8").value ="Blue"
Sheet 1.Range("S9").value="Green"

(3) New sheets are created after values found in Range: Red,Blue,Green

Sheet2.Range("B25:B").Find("Red,Blue,Green")
For Each Red in Range Then
ws.("Red").Cells(LastRow, "C").Value = cell.Offset(0, 1).Value
ws.("Red").Cells(LastRow, "D").Value = cell.Offset(0, 2).Value
ws.("Red").Cells(LastRow, "E").Value = cell.Offset(0, 3).Value
ws.("Red").Cells(LastRow, "F").Value = cell.Offset(0, 4).Value


For Each Blue in Range Then
ws.("Blue").Cells(LastRow, "C").Value = cell.Offset(0, 1).Value
ws.("Blue").Cells(LastRow, "D").Value = cell.Offset(0, 2).Value
ws.("Blue").Cells(LastRow, "E").Value = cell.Offset(0, 3).Value
ws.("Blue").Cells(LastRow, "F").Value = cell.Offset(0, 4).Value

For Each Green in Range Then
ws.("Green").Cells(LastRow, "C").Value = cell.Offset(0, 1).Value
ws.("Green").Cells(LastRow, "D").Value = cell.Offset(0, 2).Value
ws.("Green").Cells(LastRow, "E").Value = cell.Offset(0, 3).Value
ws.("Green").Cells(LastRow, "F").Value = cell.Offset(0, 4).Value

Since the number of new sheets created is dependent on the number of cells with a value in the first range given
I'd actually like to have the data copy to the new sheets within the For loop
after the sheets is created, if possible.
The way I don't have to specifically name the new sheet for where the data is to be copied.
However, I found out you cannot
have to For Each,Loop within another For Each,Loop.

So the copying of the data may have to happen after all sheets have been created
and the process steps out of the sheet creation loop.

Here's the code I've put together.

Sub Create_NEW_Sheet_And_Copy_Specific_DATA_it ()
Dim ws As Worksheet
Dim wsName As String
Dim r       As Range
Dim cell    As Range
Dim rng As Range

Set r = Sheets("Master").Range("S7:S10")
If r Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In r
If Not IsEmpty(cell) Then
With cell
   newname = cell.Value
Set ws = Worksheets.Add
ws.Move After:=Sheets(Sheets.Count)
ws.Name = newname
End With
End If

Next cell

  'For Each sht In ActiveWorkbook.Worksheets
  ' MsgBox sht.Name

With Sheets("BOM")
  Sheets("BOM").Activate
Set rng = Range("$A$25:$G$" & Cells(Rows.Count, "B").End(xlUp).Row)
For Each cell In rng
'On Error Resume Next
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 7
If cell.Value = ws.Name Then
With cell
ws.Cells(LastRow, "C").Value = cell.Offset(0, 1).Value
ws.Cells(LastRow, "D").Value = cell.Offset(0, 2).Value
ws.Cells(LastRow, "E").Value = cell.Offset(0, 3).Value
ws.Cells(LastRow, "F").Value = cell.Offset(0, 4).Value
ws.Cells(LastRow, "G").Value = cell.Offset(0, 5).Value
End With
End If
Next cell
End With

Any help ,as always is greatly appreciated.

Thanks,

BDB