Option Explicit

Public Sub CopyRowsToSheetN()
'copies rows of data from sheet named 'Data' to sheet
'named 'Sheetn' where n is the first character of the text
'in the first cell if any. Creates Sheetn if necessary.

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)

'copies the row to the new sheet at the current row
For Each cell In rng.Cells
If Len(cell.Text) 0 Then
Set wksT = GetWorksheet(wks.Parent, "Sheet" & Left(cell.Text, 1))
cell.EntireRow.Copy wksT.Columns("A").Cells(cell.Row)
End If
Next cell

'compresses each list to the top
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
'Returns the wkbW worksheet named.
'Adds it, if it doesn't exist.
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 in message
...
Hello from Steved

I would like to shift the below to their respective sheets.
Using the first numeral 40285 in this case 4 to sheet4,
70382 to sheet7, 50604 to sheet5 and so on. Ive got over a
thousand rows to do. Thankyou.

40285 43. 126.4
10883 39. 81.2
70382 37. 76.77
50604 37. 71.14
70458 37. 84.31
10787 36. 57.94
20710 36. 46.16
70420 33. 80.9
10725 33. 48.5
50464 32. 46.9
50593 32. 46.9
50098 30. 117.2
10870 29. 58.2
50594 29. 51.14
20794 28. 53.
10869 28. 43.3