Separating a List onto multiple worksheets in the same workbook based off 1 criteria

[DMRbaxter]

I have a template that I'm trying to develop for daily use in my
office. The template is a tool to help my supervisors check the work
for the next day. I work for a service organization that covers a 3
state area.....I have routers that plan the day for the techs but I
need a fast tool for my supervisors to be able to be the safety net if
you will for them. I can have them import the routes into map point
but the problem is now it is very manual and time consuming.....I
would to create a code that would take the list and separate each
route into its own worksheet in the workbook.....I just have no idea
where to start. Any ideas???

 

[Guest]

Let's say you have a worksheet with the following information on it.

Col A Col B
Route # Stop #

And your data is stored in rows 2 - N

Try something like this:

Sub SPlitRoutes()
Dim aWB As Workbook
Dim aWS As Worksheet
Dim newWS As Worksheet
Dim i As Integer
Dim lrow As Integer

Set aWB = ActiveWorkbook
Set aWS = ActiveSheet

For i = 2 To aWS.Cells(Rows.Count, 1).End(xlUp).Row
Set newWS = Nothing
On Error Resume Next
Set newWS = aWB.Worksheets(aWS.Cells(i, 1))
On Error GoTo 0
If newWS Is Nothing Then
Debug.Print aWS.Cells(i, 1).Value
Set newWS = Worksheets.Add(After:=Worksheets(aWB.Worksheets.Count))
newWS.Name = aWS.Cells(i, 1).Value
newWS.Cells(1, 1).Value = aWS.Cells(1, 1).Value
newWS.Cells(1, 2).Value = aWS.Cells(1, 2).Value
newWS.Cells(2, 1).Value = aWS.Cells(i, 1).Value
newWS.Cells(2, 2).Value = aWS.Cells(i, 2).Value
Else
lrow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
newWS.Cells(lrow + 1, 1) = aWS.Cells(i, 1)
newWS.Cells(lrow + 1, 2) = aWS.Cells(i, 2)
End If

Next i
End Sub

 

[DMRbaxter]

Let's say you have a worksheet with the following information on it.

Col A Col B
Route # Stop #

And your data is stored in rows 2 - N

Try something like this:

Sub SPlitRoutes()
Dim aWB As Workbook
Dim aWS As Worksheet
Dim newWS As Worksheet
Dim i As Integer
Dim lrow As Integer

Set aWB = ActiveWorkbook
Set aWS = ActiveSheet

For i = 2 To aWS.Cells(Rows.Count, 1).End(xlUp).Row
Set newWS = Nothing
On Error Resume Next
Set newWS = aWB.Worksheets(aWS.Cells(i, 1))
On Error GoTo 0
If newWS Is Nothing Then
Debug.Print aWS.Cells(i, 1).Value
Set newWS = Worksheets.Add(After:=Worksheets(aWB.Worksheets.Count))
newWS.Name = aWS.Cells(i, 1).Value
newWS.Cells(1, 1).Value = aWS.Cells(1, 1).Value
newWS.Cells(1, 2).Value = aWS.Cells(1, 2).Value
newWS.Cells(2, 1).Value = aWS.Cells(i, 1).Value
newWS.Cells(2, 2).Value = aWS.Cells(i, 2).Value
Else
lrow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
newWS.Cells(lrow + 1, 1) = aWS.Cells(i, 1)
newWS.Cells(lrow + 1, 2) = aWS.Cells(i, 2)
End If

Next i
End Sub

So here are the correct columns:

AQ AR
IND-1234-FSS1 1
IND-1234-FSS1 2
IND-1234-FSS1 3
IND-1234-FSS1 4
IND-4321-FSS1 1
IND-4321-FSS1 2
IND-4321-FSS1 3
FTW-4321-FSS1 1
FTW-4321-FSS1 2
FTW-4321-FSS1 3
FTW-4321-FSS1 4
FTW-4321-FSS1 5

How would the formula change, you have to excuse me I'm new at this?

 

[DMRbaxter]

So here are the correct columns:

AQ AR
IND-1234-FSS1 1
IND-1234-FSS1 2
IND-1234-FSS1 3
IND-1234-FSS1 4
IND-4321-FSS1 1
IND-4321-FSS1 2
IND-4321-FSS1 3
FTW-4321-FSS1 1
FTW-4321-FSS1 2
FTW-4321-FSS1 3
FTW-4321-FSS1 4
FTW-4321-FSS1 5

How would the formula change, you have to excuse me I'm new at this?

I also need it to copy the entire row into the new worksheets not just
the 2 cells......also thanks for your help so far

 

[Guest]

Any line that shows
aws.cells(something,1) should change to aws.cells(something,"AQ")
aws.cells(something,2) should change to aws.cells(something,"AR")

 

[DMRbaxter]

Any line that shows
aws.cells(something,1) should change to aws.cells(something,"AQ")
aws.cells(something,2) should change to aws.cells(something,"AR")

So is there a way to make it copy all the rows that match column AQ so
I would need it to copy A-BR that into the new sheet

 

[Guest]

Change the whole if/then as follows:

If newWS Is Nothing Then
Set newWS = Worksheets.Add(After:=Worksheets(aWB.Worksheets.Count))
newWS.Name = aWS.Cells(i, "AQ").Value
newWS.rows(1).Value = aWS.rows(1).Value
newWS.rows(2).Value = aWS.rows(i).Value
Else
lrow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
newWS.rows(lrow + 1).value = aWS.rows(i).value
End If