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

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

Hello Bob From Steved

I've being trying to find why, but I am not finding a
solution, can you explan to me What I need to do please
to stop Subscript out of range, I know I should be able to
work this out for myself but I just cannot think. Thankyou.

Subscript out of range (Error 9)

Set wks = ThisWorkbook.Worksheets("Data")

-----Original Message-----
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).EntireRow.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



.

Hello from Steved

Further to my last reply
Option Explicit
Option Explicit is designed to find a error
this is as far as I got.

Cheers.


-----Original Message-----
Hello Bob From Steved

I've being trying to find why, but I am not finding a
solution, can you explan to me What I need to do please
to stop Subscript out of range, I know I should be able
to
work this out for myself but I just cannot think.
Thankyou.

Subscript out of range (Error 9)

Set wks = ThisWorkbook.Worksheets("Data")

-----Original Message-----
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).EntireRow.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



.

.

A 'subscript' is the index into a collection or array. If "Set wks =
ThisWorkbook.Worksheets("Data")" is giving you this trouble, you probably do
not have a worksheet named "Data" in the workbook the code is in. If so,
using "Data" as an index into the Worksheets collection is invalid (The
"Data" subscript is not among the range of valid index values). The code
expects the data to start in the first column of a worksheet named "Data".
Put your data into a worksheet named "Data."

(If you prefer to change the data sheet name "Data" in the code to another
name, you may, but avoid using a name that begins with "Sheet". In any case,
the code's name for the data sheet and the data sheet name itself need to be
the same.)

Notice too, that I used ThisWorkbook.Worksheets("Data"). This means that the
code is looking for the worksheet named "Data" in the workbook that the code
it in, and not any other workbook. If you want to put the code in one
workbook, but have it work on other workbooks (that have data in worksheets
named "Data"), change "ThisWorkbook" to "ActiveWorkbook."

Let me know how it goes.

Regards,
Bob

"Steved" wrote in message
...
Hello Bob From Steved

I've being trying to find why, but I am not finding a
solution, can you explan to me What I need to do please
to stop Subscript out of range, I know I should be able to
work this out for myself but I just cannot think. Thankyou.

Subscript out of range (Error 9)

Set wks = ThisWorkbook.Worksheets("Data")

-----Original Message-----
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).EntireRow.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



.

"Option Explicit" tells VBA to require you to declare all of your variables
(using Dim i As Integer, for instance). This helps you to prevent errors in
variable naming and logic errors that may arise from assigning the wrong
type of values to the wrong variables. You can remove "Option Explicit", but
I recommend using it and learning to declare variables properly. If you are
using undeclared variables now and add Option Explicit, when you start the
code, VBA will tell you the "variable is not defined." So just define
(declare) it and try again. Eventually you will get them all defined and
learn better how to declare variables. If you want to make Option Explicit
appear in every module when you add a new one to a project or start a new
project, go to Tools Options Editor and check the second check box
"Require variable declaration."

Examples:
Dim cell As Range
Dim rng As Range, oldSelection As Range
Dim wks As Worksheet, wksT As Worksheet
Dim iColumn as Integer
Dim lRow as Long
Dim message as String

If this is all too much bother, just comment "Option Explicit" out or delete
it.

Bob

"Steved" wrote in message
...
Hello from Steved

Further to my last reply
Option Explicit
Option Explicit is designed to find a error
this is as far as I got.

Cheers.


-----Original Message-----
Hello Bob From Steved

I've being trying to find why, but I am not finding a
solution, can you explan to me What I need to do please
to stop Subscript out of range, I know I should be able
to
work this out for myself but I just cannot think.
Thankyou.

Subscript out of range (Error 9)

Set wks = ThisWorkbook.Worksheets("Data")

-----Original Message-----
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).EntireRow.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



.

.

Hello Bob From Steved

Just one of those days when I feel like a fool.

It is just What require and thankyou for taking timeout

Could a moderation to your code be changed please.
Your code automatically puts in the Sheets

Can the code reconize as it does now 1 and put it in a
Named Sheet "City Depot" instead of Sheet1 as it does now
2 for "Roskill Depot" 3 for "Papakura" and so on to 9

I thankyou once again Bob for your Time.


-----Original Message-----
A 'subscript' is the index into a collection or array.
If "Set wks =
ThisWorkbook.Worksheets("Data")" is giving you this
trouble, you probably do
not have a worksheet named "Data" in the workbook the
code is in. If so,
using "Data" as an index into the Worksheets collection
is invalid (The
"Data" subscript is not among the range of valid index
values). The code
expects the data to start in the first column of a
worksheet named "Data".
Put your data into a worksheet named "Data."

(If you prefer to change the data sheet name "Data" in
the code to another
name, you may, but avoid using a name that begins
with "Sheet". In any case,
the code's name for the data sheet and the data sheet
name itself need to be
the same.)

Notice too, that I used ThisWorkbook.Worksheets("Data").
This means that the
code is looking for the worksheet named "Data" in the
workbook that the code
it in, and not any other workbook. If you want to put the
code in one
workbook, but have it work on other workbooks (that have
data in worksheets
named "Data"), change "ThisWorkbook" to "ActiveWorkbook."

Let me know how it goes.

Regards,
Bob

"Steved" wrote in
message
...
Hello Bob From Steved

I've being trying to find why, but I am not finding a
solution, can you explan to me What I need to do please
to stop Subscript out of range, I know I should be able
to
work this out for myself but I just cannot think.
Thankyou.

Subscript out of range (Error 9)

Set wks = ThisWorkbook.Worksheets("Data")

-----Original Message-----
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).EntireRow.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



.



.