Hello from Steved

I Would like to copy The first row ( Headings ) to other sheets please.

What is required is is that it inserts a row then copies the heading to the
inserted row, what is required please to the macro below to accomplish this.
Thankyou.

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

Hello From Steved

Ok I've named the sheets 1-City, 2-Roskill, 3-Papakura, 4-Wiri, 5-Shore,
6-Orewa, 7-Swanson and 8-Panmure, using the below where wouldI place it in
the full macro please, which is below thankyou.

Application.Goto Reference:="R1C1:R1C5"
Selection.Copy
Sheets("1-City").Select
ActiveSheet.Paste



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
Private Function GetWorksheet(wkbW As Workbook, _
strName As String) As Worksheet
Dim wks As Worksheet
On Error Resume Next
Set wks = wkbW.Worksheets(strName)
On Error GoTo 0
If (wks Is Nothing) Then
Set wks = wkbW.Worksheets.Add(After:=Worksheets("Data"))
wks.Name = strName
End If
Set GetWorksheet = wks
Set wks = Nothing
End Function



"Steved" wrote:

Hello from Steved

I Would like to copy The first row ( Headings ) to other sheets please.

What is required is is that it inserts a row then copies the heading to the
inserted row, what is required please to the macro below to accomplish this.
Thankyou.

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