Move Rows based on cell value

[farmercalgary]

Help! I am trying to create a VBA Code that is pulls from a list that equals one of the following: "Transport" "Level 1/2" "Level 3" "One to One" or "Youth Work". The information starts on the 2nd row and 8th Column. I need all of the information in the row to sort into their own worksheets and start at Row 2 Column 1, however I am only able to get "Transport" to sort, and then random ones from the other list of names. Here is the code I have tried...

Sub Diversion()


Dim x As Integer
Dim y As Integer
Dim i As Integer
Dim shSource As Worksheet
Dim shTarget1 As Worksheet
Dim shTarget2 As Worksheet
Dim shTarget3 As Worksheet
Dim shTarget4 As Worksheet
Dim shTarget5 As Worksheet


Set shSource = ThisWorkbook.Sheets("Main")
Set shTarget1 = ThisWorkbook.Sheets("Transport")
Set shTarget2 = ThisWorkbook.Sheets("Level 2")
Set shTarget3 = ThisWorkbook.Sheets("Level 3")
Set shTarget4 = ThisWorkbook.Sheets("One to One")
Set shTarget5 = ThisWorkbook.Sheets("Youth Work")



If shTarget1.Cells(2, 8).Value = "Transport" Then
x = 2
Else
x = shTarget1.Cells(2, 8).CurrentRegion.Rows.Count + 2
End If



If shTarget2.Cells(2, 8).Value = "Level 1/2" Then
y = 2
Else
y = shTarget2.Cells(2, 8).CurrentRegion.Rows.Count + 2
End If


If shTarget3.Cells(2, 8).Value = "Level 3" Then
y = 2
Else
y = shTarget3.Cells(2, 8).CurrentRegion.Rows.Count + 2
End If



If shTarget4.Cells(2, 8).Value = "One to One" Then
y = 2
Else
y = shTarget4.Cells(2, 8).CurrentRegion.Rows.Count + 2
End If



If shTarget5.Cells(2, 8).Value = "Youth Work" Then
y = 2
Else
y = shTarget5.Cells(2, 8).CurrentRegion.Rows.Count + 2
End If

i = 8


Do While i <= 10000
    If Cells(i, 8).Value = "Transport" Then
    shSource.Rows(i).Copy
    shTarget1.Cells(x, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    x = x + 1
    GoTo Line1
    ElseIf Cells(i, 8).Value = "Level 1/2" Then
    shSource.Rows(i).Copy
    shTarget2.Cells(y, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    x = x + 1
    GoTo Line1
    ElseIf Cells(i, 8).Value = "Level 3" Then
    shSource.Rows(i).Copy
    shTarget3.Cells(y, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    x = x + 1
    GoTo Line1
    ElseIf Cells(i, 8).Value = "One to One" Then
    shSource.Rows(i).Copy
    shTarget4.Cells(y, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    x = x + 1
    GoTo Line1
    ElseIf Cells(i, 8).Value = "Youth Work" Then
    shSource.Rows(i).Copy
    shTarget5.Cells(y, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    x = x + 1
    GoTo Line1
    End If
i = i + 1



Line1: Loop

End Sub

 

[Logit]

.
Here is a routine I use often :

Option Explicit
Sub CreateSheets()

    Dim Cell    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet

        Set RngBeg = Worksheets("Sheet1").Range("A2")
        Set RngEnd = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)

        ' Exit if the list is empty.
        If RngEnd.Row < RngBeg.Row Then Exit Sub
Application.ScreenUpdating = False
        For Each Cell In Worksheets("Sheet1").Range(RngBeg, RngEnd)
            On Error Resume Next
                ' No error means the worksheet exists.
                Set Wks = Worksheets(Format(Cell.Value, "[$-409]mmm;@"))

                ' Add a new worksheet and name it.
                If Err <> 0 Then
                    Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    Wks.Name = Format(Cell.Value, "[$-409]mmm;@")
                End If
            On Error GoTo 0
        Next Cell
Application.ScreenUpdating = True

MakeHeaders
End Sub

Sub MakeHeaders()
Dim srcSheet As String
Dim dst As Integer
srcSheet = "Sheet1"
Application.ScreenUpdating = False
For dst = 1 To Sheets.Count
    If Sheets(dst).Name <> srcSheet Then
    Sheets(srcSheet).Rows("1:1").Copy
    Sheets(dst).Activate
    Sheets(dst).Range("A1").PasteSpecial xlPasteValues
    'ActiveSheet.PasteSpecial xlPasteValues
    Sheets(dst).Range("A1").Select
    End If
Next
Application.ScreenUpdating = True
CopyData
End Sub

Sub CopyData()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
On Error Resume Next
Lastrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Dim ans As String
Dim ans2 As String

NoVisi

    For i = 2 To Lastrow
    ans = Sheets("Sheet1").Cells(i, 1).Value
    ans2 = Format(ans, "[$-409]mmm;@")
        Sheets("Sheet1").Rows(i).Copy Sheets(ans2).Rows(Sheets(ans2).Cells(Rows.Count, "A").End(xlUp).Row + 1)
        Sheets(ans2).Columns("A:C").AutoFit
    Next
    

Visi

Application.ScreenUpdating = True

Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A1").Select
Exit Sub

Application.ScreenUpdating = True

End Sub

Sub NoVisi()
Dim CommandButton1 As Object

CommandButton1.Visible = False

End Sub

Sub Visi()
Dim CommandButton1 As Object

CommandButton1.Visible = True
End Sub

Download workbook : New Sheets n Data From List.xlsm