Hello from Steved

Below works as it should.

Our IT section made changes, hence I need to ask your help
please. At the moment it looks in Col A and uses the first
numeric say 1, it moves all data associated with 1 to
sheet1 which it created 2 to Sheet2 and so on.

Ok I am not a code specialist so I require your help.
Ok I will present 2 situations
1, Can the below be change to pickup the first 2 Char
ie Sh, Sw which stands for "Shore", "Swanson"

2, I have cities City, Roskill, Papakura, Wiri, Shore,
Orewa, Swanson, Waiheke. Can this be done with the below
please.

Thankyou.

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

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, 2))
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


--
Regards,
Tom Ogilvy

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

Below works as it should.

Our IT section made changes, hence I need to ask your help
please. At the moment it looks in Col A and uses the first
numeric say 1, it moves all data associated with 1 to
sheet1 which it created 2 to Sheet2 and so on.

Ok I am not a code specialist so I require your help.
Ok I will present 2 situations
1, Can the below be change to pickup the first 2 Char
ie Sh, Sw which stands for "Shore", "Swanson"

2, I have cities City, Roskill, Papakura, Wiri, Shore,
Orewa, Swanson, Waiheke. Can this be done with the below
please.

Thankyou.

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

Hello from Steved

Thankyou. Tom

-----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, 2))
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


--
Regards,
Tom Ogilvy

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

Below works as it should.

Our IT section made changes, hence I need to ask your
help
please. At the moment it looks in Col A and uses the
first
numeric say 1, it moves all data associated with 1 to
sheet1 which it created 2 to Sheet2 and so on.

Ok I am not a code specialist so I require your help.
Ok I will present 2 situations
1, Can the below be change to pickup the first 2 Char
ie Sh, Sw which stands for "Shore", "Swanson"

2, I have cities City, Roskill, Papakura, Wiri, Shore,
Orewa, Swanson, Waiheke. Can this be done with the below
please.

Thankyou.

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





.

This statement - "Sheet" & Left(cell.Text, 1) - from the code makes a new
word using the word "Sheet" plus the first letter on the left of the text in
the cell. A new sheet is created for each unique word created.

If the cell has the word "Waiheke" in it, the statement above would make the
string "SheetW".

If you were to change it to this:

"Sheet" & Left(cell.Text, 2)

it would make a string using the word "Sheet" plus the first TWO characters
on the left of the string in the cell.

If the cell has the word "Waiheke" in it, the statement would make the
string "SheetWa".

Left(X, Y) returns Y characters from the left end of the string X.

The "&" (ampersand) connects many words into one: "Sheet" & "Foo" becomes
"SheetFoo",
Sheet" & "_Foo" & "_Bar" become "Sheet_Foo_Bar" , etc.

If the cities City, Roskill, Papakura, Wiri, Shore, Orewa, Swanson, Waiheke
were in the first column of the data worksheet, the sheets named SheetC,
SheetR, SheetP, SheetW, SheetS, SheetO would be created and the data sorted
accordingly.

If you change Left(cell.Text, 1) to Left(cell.Text, 2), sheets named
SheetCi, SheetRo, SheetPa, SheetWi, SheetSh, SheetOr, SheetSw, SheetWa would
be created and the data sorted accordingly.

If you replaced "Sheet" & Left(cell.Text, 1) with cell.Text, sheets named
City, Roskill, Papakura, Wiri, Shore, Orewa, Swanson, Waiheke would be
created and each city would have its own sheet and only that city's data
would appear on the sheet.

Does this help?

Bob


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

Below works as it should.

Our IT section made changes, hence I need to ask your help
please. At the moment it looks in Col A and uses the first
numeric say 1, it moves all data associated with 1 to
sheet1 which it created 2 to Sheet2 and so on.

Ok I am not a code specialist so I require your help.
Ok I will present 2 situations
1, Can the below be change to pickup the first 2 Char
ie Sh, Sw which stands for "Shore", "Swanson"

2, I have cities City, Roskill, Papakura, Wiri, Shore,
Orewa, Swanson, Waiheke. Can this be done with the below
please.

Thankyou.

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

Hello Bob from Steved

Thankyou it helps

-----Original Message-----
This statement - "Sheet" & Left(cell.Text, 1) - from the
code makes a new
word using the word "Sheet" plus the first letter on the
left of the text in
the cell. A new sheet is created for each unique word
created.

If the cell has the word "Waiheke" in it, the statement
above would make the
string "SheetW".

If you were to change it to this:

"Sheet" & Left(cell.Text, 2)

it would make a string using the word "Sheet" plus the
first TWO characters
on the left of the string in the cell.

If the cell has the word "Waiheke" in it, the statement
would make the
string "SheetWa".

Left(X, Y) returns Y characters from the left end of the
string X.

The "&" (ampersand) connects many words into one: "Sheet"
& "Foo" becomes
"SheetFoo",
Sheet" & "_Foo" & "_Bar" become "Sheet_Foo_Bar" , etc.

If the cities City, Roskill, Papakura, Wiri, Shore,
Orewa, Swanson, Waiheke
were in the first column of the data worksheet, the
sheets named SheetC,
SheetR, SheetP, SheetW, SheetS, SheetO would be created
and the data sorted
accordingly.

If you change Left(cell.Text, 1) to Left(cell.Text, 2),
sheets named
SheetCi, SheetRo, SheetPa, SheetWi, SheetSh, SheetOr,
SheetSw, SheetWa would
be created and the data sorted accordingly.

If you replaced "Sheet" & Left(cell.Text, 1) with
cell.Text, sheets named
City, Roskill, Papakura, Wiri, Shore, Orewa, Swanson,
Waiheke would be
created and each city would have its own sheet and only
that city's data
would appear on the sheet.

Does this help?

Bob


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

Below works as it should.

Our IT section made changes, hence I need to ask your
help
please. At the moment it looks in Col A and uses the
first
numeric say 1, it moves all data associated with 1 to
sheet1 which it created 2 to Sheet2 and so on.

Ok I am not a code specialist so I require your help.
Ok I will present 2 situations
1, Can the below be change to pickup the first 2 Char
ie Sh, Sw which stands for "Shore", "Swanson"

2, I have cities City, Roskill, Papakura, Wiri, Shore,
Orewa, Swanson, Waiheke. Can this be done with the below
please.

Thankyou.

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





.