Copy Rows To desinated Sheet Please. But First Creating Them.
 

Hello from Steved

I need the below please to be to do the following

I have ten cities City, Roskill, Papakura, Wiri, Shore, Orewa, Swanson,
Panmure, Waiheke.

In Col A I have the cities.
Ok I start it in Row A6.
Each row is from Col A to Col Q to be copied to each worksheet.
I have 250 Rows of information.

Public Sub CopyRowsToSheetN()
Application.ScreenUpdating = False
Dim cell As Range
Dim rng As Range, oldSelection As Range
Dim wks As Worksheet, wksT As Worksheet
Set oldSelection = Selection
Set wks = ThisWorkbook.Worksheets("Data")
Set rng = Intersect(wks.Columns("A"), wks.UsedRange)
For Each cell In rng.Cells
If Len(cell.Text) 0 Then
Set wksT = GetWorksheet(wks.Parent, "" & Left(cell.Text, 11))
cell.EntireRow.Copy wksT.Columns("A").Cells(cell.Row)
End If
Next cell
On Error Resume Next
For Each wksT In wks.Parent.Worksheets
wksT.Columns("A").SpecialCells(xlCellTypeBlanks).E ntireRow.Delete xlUp
Next
Application.Goto oldSelection
Application.ScreenUpdating = True
End Sub

Thankyou.

Copy Rows To desinated Sheet Please. But First Creating Them.
 

your question is not clear.

You want to copy from sheet Data the range A6:Q255 to each worksheet

DIM Source as Range
DIM WS as Worksheet
SET Source = Worksheets("Data").Range("A6:Q255")
FOR EACH ws IN Worksheets
IF ws.Name <"Data" THEN
WITH Source
ws.Range("A1").Resize(.Rows.Count,.Columns.Count). Value = .Value
END WITH
END IF
NEXT



"Steved" wrote:

Hello from Steved

I need the below please to be to do the following

I have ten cities City, Roskill, Papakura, Wiri, Shore, Orewa, Swanson,
Panmure, Waiheke.

In Col A I have the cities.
Ok I start it in Row A6.
Each row is from Col A to Col Q to be copied to each worksheet.
I have 250 Rows of information.

Public Sub CopyRowsToSheetN()
Application.ScreenUpdating = False
Dim cell As Range
Dim rng As Range, oldSelection As Range
Dim wks As Worksheet, wksT As Worksheet
Set oldSelection = Selection
Set wks = ThisWorkbook.Worksheets("Data")
Set rng = Intersect(wks.Columns("A"), wks.UsedRange)
For Each cell In rng.Cells
If Len(cell.Text) 0 Then
Set wksT = GetWorksheet(wks.Parent, "" & Left(cell.Text, 11))
cell.EntireRow.Copy wksT.Columns("A").Cells(cell.Row)
End If
Next cell
On Error Resume Next
For Each wksT In wks.Parent.Worksheets
wksT.Columns("A").SpecialCells(xlCellTypeBlanks).E ntireRow.Delete xlUp
Next
Application.Goto oldSelection
Application.ScreenUpdating = True
End Sub

Thankyou.

Copy Rows To desinated Sheet Please. But First Creating Them.
 

Hello Patrick from Steved

Firstly Thankyou.

Ok I have a renamed Sheet1 and called it Data.

I have 9 cities City, Roskill, Papakura, Wiri, Shore, Orewa, Swanson,
Panmure, Waiheke.

On the worksheet called Data I would like it to insert worksheets with the
above Cities ie City , Roskill and so on then copy the value from the data
sheet.

Hopefully you can help me.

Thankyou.



"Patrick Molloy" wrote:

your question is not clear.

You want to copy from sheet Data the range A6:Q255 to each worksheet

DIM Source as Range
DIM WS as Worksheet
SET Source = Worksheets("Data").Range("A6:Q255")
FOR EACH ws IN Worksheets
IF ws.Name <"Data" THEN
WITH Source
ws.Range("A1").Resize(.Rows.Count,.Columns.Count). Value = .Value
END WITH
END IF
NEXT



"Steved" wrote:

Hello from Steved

I need the below please to be to do the following

I have ten cities City, Roskill, Papakura, Wiri, Shore, Orewa, Swanson,
Panmure, Waiheke.

In Col A I have the cities.
Ok I start it in Row A6.
Each row is from Col A to Col Q to be copied to each worksheet.
I have 250 Rows of information.

Public Sub CopyRowsToSheetN()
Application.ScreenUpdating = False
Dim cell As Range
Dim rng As Range, oldSelection As Range
Dim wks As Worksheet, wksT As Worksheet
Set oldSelection = Selection
Set wks = ThisWorkbook.Worksheets("Data")
Set rng = Intersect(wks.Columns("A"), wks.UsedRange)
For Each cell In rng.Cells
If Len(cell.Text) 0 Then
Set wksT = GetWorksheet(wks.Parent, "" & Left(cell.Text, 11))
cell.EntireRow.Copy wksT.Columns("A").Cells(cell.Row)
End If
Next cell
On Error Resume Next
For Each wksT In wks.Parent.Worksheets
wksT.Columns("A").SpecialCells(xlCellTypeBlanks).E ntireRow.Delete xlUp
Next
Application.Goto oldSelection
Application.ScreenUpdating = True
End Sub

Thankyou.

Copy Rows To desinated Sheet Please. But First Creating Them.
 

Hello Patrick from Steved

If you get to read this I have now a macro that will create the seperate
worksheets

Can your effort please Identify say city and put it in City worksheet,
Roskill into Roskill worksheet and so on.

Thankyou.

"Steved" wrote:

Hello Patrick from Steved

Firstly Thankyou.

Ok I have a renamed Sheet1 and called it Data.

I have 9 cities City, Roskill, Papakura, Wiri, Shore, Orewa, Swanson,
Panmure, Waiheke.

On the worksheet called Data I would like it to insert worksheets with the
above Cities ie City , Roskill and so on then copy the value from the data
sheet.

Hopefully you can help me.

Thankyou.



"Patrick Molloy" wrote:

your question is not clear.

You want to copy from sheet Data the range A6:Q255 to each worksheet

DIM Source as Range
DIM WS as Worksheet
SET Source = Worksheets("Data").Range("A6:Q255")
FOR EACH ws IN Worksheets
IF ws.Name <"Data" THEN
WITH Source
ws.Range("A1").Resize(.Rows.Count,.Columns.Count). Value = .Value
END WITH
END IF
NEXT



"Steved" wrote:

Hello from Steved

I need the below please to be to do the following

I have ten cities City, Roskill, Papakura, Wiri, Shore, Orewa, Swanson,
Panmure, Waiheke.

In Col A I have the cities.
Ok I start it in Row A6.
Each row is from Col A to Col Q to be copied to each worksheet.
I have 250 Rows of information.

Public Sub CopyRowsToSheetN()
Application.ScreenUpdating = False
Dim cell As Range
Dim rng As Range, oldSelection As Range
Dim wks As Worksheet, wksT As Worksheet
Set oldSelection = Selection
Set wks = ThisWorkbook.Worksheets("Data")
Set rng = Intersect(wks.Columns("A"), wks.UsedRange)
For Each cell In rng.Cells
If Len(cell.Text) 0 Then
Set wksT = GetWorksheet(wks.Parent, "" & Left(cell.Text, 11))
cell.EntireRow.Copy wksT.Columns("A").Cells(cell.Row)
End If
Next cell
On Error Resume Next
For Each wksT In wks.Parent.Worksheets
wksT.Columns("A").SpecialCells(xlCellTypeBlanks).E ntireRow.Delete xlUp
Next
Application.Goto oldSelection
Application.ScreenUpdating = True
End Sub

Thankyou.