Move Rows based on cell value

farmercalgary

New Member
Joined
Sep 22, 2020
Messages
1
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
  3. Mobile
  4. Web
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...

VBA Code:
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
 
Last edited by a moderator:

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
.
Here is a routine I use often :

VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,287
Members
448,562
Latest member
Flashbond

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top