copy rows to each new sheet

[sean1541]

Hi i want to be able to copy data from rows on Master sheet to new sheets
this is what i have so far it will put row data only for first row i want it to move down all rows that have data in
Colum C Master sheet ahd copy to all new sheets.
Thanks for any Help.
Sean

Sub Create()
Dim rng As Range, rngLoop As Range, ws As Worksheet

If Not SheetExists("Template") Then
MsgBox "The Template sheet does not exist. Make sure the Template is included before processing.", vbCritical + vbOKOnly
Exit Sub
End If

Application.ScreenUpdating = False

With ActiveWorkbook.Sheets("Master")
Set rng = .Range("c2", "c" & .Cells(Rows.Count, "c").End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlTextValues)

For Each rngLoop In rng
If Not SheetExists(rngLoop.Value) Then
ActiveWorkbook.Sheets("Template").Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
Set ws = ActiveSheet
ws.Name = rngLoop.Value
Else
Set ws = ActiveWorkbook.Sheets(rngLoop.Value)
End If
ws.Range("A2").Resize(, 11).Value = .Range("A2:K2").Value
ws.Range("A130").Resize(, 11).Value = .Range(.Cells(rngLoop.Row, 1), .Cells(rngLoop.Row, 11)).Value


Next
.Activate
End With

Application.ScreenUpdating = True
End Sub



Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet

If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
SheetExists = Not sht Is Nothing
End Function

 

[rollis13]

Maybe, but not sure I correctly understood your request.

Change:
ws.Range("A2").Resize(, 11).Value = .Range("A2:K2").Value

To:
ws.Range("A2").Resize(, 11).Value = .Range("A" & rngLoop.Row & ":K" & rngLoop.Row).Value

 

[sean1541]

ws.Range("A2").Resize(, 11).Value = .Range("A" & rngLoop.Row & ":K" & rngLoop.Row).Value

Thanks a million i have been trying to fix this for long time
I realy appreciate your help works perfect.
Thank you
Regards,
Sean.

 

[rollis13]

Thanks for the positive feedback, glad having been of some help.