Cut/Paste into Different sheet

[cns324]

Looking to create code that will look for the word "Complete" (will be the only word listed) in column M, Sheet1 and if it finds it, will cut the whole row and paste it at the bottom of data on Sheet2, named: Completed. Then delete the empty rows at are left after they have been cut.

2nd item: similar to above, but need it to look at column B, sheet1, need it to look for *Remove*, or *Change*, or *Relocation*, if it finds any of these words, (there will be other words also) then it will cut the whole row and paste to bottom of data on Sheet4, named: Review. Then delete the empty rows that are left after they have been cut. It can look at each of the 3 words in separate steps or code if needed.

Thanks

 

[kevin9999]

Do you have data in column A of Sheet1, and does row 1 contain headers, with the data starting in row 2?

 

[cns324]

Yes there will be data in columns A-K and yes row 1 does contain headers.

 

[kevin9999]

Try the following with a copy of your data. Without actually seeing your worksheets, there's a bit of guesswork going on here...

Option Explicit
Option Compare Text
Sub cns324sub()
    Dim ws1Row As Long, ws2Row As Long, ws3Row As Long, x As Long
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, TestRng As Range
    Set ws1 = Sheet1
    Set ws2 = Sheets("Completed")
    Set ws3 = Sheets("Review")
   
    '1. Move the 'Complete' rows
    ws1Row = ws1.Cells.Find("*", , xlFormulas, , 1, 2).Row
    ws2Row = ws2.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
   
    Set TestRng = ws1.Range(ws1.Cells(2, 13), ws1.Cells(ws1Row, 13))
    x = Application.CountIf(TestRng, "Complete")
    If x = 0 Then
        MsgBox "No Complete records found"
        GoTo Stage2
    End If
   
    With ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1Row, 13))
        .AutoFilter 13, "Complete"
        .Offset(1).Resize(.Rows.Count - 1).Copy ws2.Cells(ws2Row, 1)
        .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        .AutoFilter
    End With
   
Stage2:
    '1. Move the other rows
    Dim i As Long, c As Range, arr() As Variant
    ws3Row = ws3.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
    ws1Row = ws1.Cells(Rows.Count, 2).End(xlUp).Row
   
    Set TestRng = ws1.Range(ws1.Cells(2, 2), ws1.Cells(ws1Row, 2))
    x = Application.CountIfs(TestRng, "*Remove *") + _
    Application.CountIfs(TestRng, "*Change*") + _
    Application.CountIfs(TestRng, "*Relocate*")
    If x = 0 Then
        MsgBox "No Remove, Change or Relocation records found"
        Exit Sub
    End If
   
    For Each c In ws1.Range("B2:B" & ws1Row)
        If c.Value Like "*Remove*" Or _
            c.Value Like "*Change*" Or _
            c.Value Like "*Relocation*" Then
            ReDim Preserve arr(i)
            arr(i) = c.Value
            i = i + 1
        End If
    Next c
   
    With ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1Row, 13))
        .AutoFilter 2, Array(arr), 7
        .Offset(1).Resize(.Rows.Count - 1).Copy ws3.Cells(ws3Row, 1)
        .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        .AutoFilter
    End With
End Sub

 

[kevin9999]

@cns324 have you had the chance to try the code yet?

 

[cns324]

Yes, I was able to test it today, it works prefect! I loved the message boxes that you included. A HUGE THANK YOU!

 

[kevin9999]

You're welcome & thanks for the feedback

 

[kevin9999]

If you're interested, I have a slightly tidier version of the code (better method to determine whether there are any Remove, Change or Relocate records)...

Option Explicit
Option Compare Text
Sub cns324sub()
    Dim ws1Row As Long, ws2Row As Long, ws3Row As Long, x As Long
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, TestRng As Range
    Set ws1 = Sheet1
    Set ws2 = Sheets("Completed")
    Set ws3 = Sheets("Review")
    
    '1. Move the 'Completed' rows
    ws1Row = ws1.Cells.Find("*", , xlFormulas, , 1, 2).Row
    ws2Row = ws2.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
        
    With ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1Row, 13))
        .AutoFilter 13, "Complete"
        If ws1.Range("A1:A" & ws1Row).SpecialCells(12).Count = 1 Then
            MsgBox "No Complete records found"
            .AutoFilter
            GoTo Stage2
        End If
        .Offset(1).Resize(.Rows.Count - 1).Copy ws2.Cells(ws2Row, 1)
        .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        .AutoFilter
    End With
    
Stage2:
    '1. Move the other rows
    Dim i As Long, c As Range, arr() As Variant
    ws3Row = ws3.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
    ws1Row = ws1.Cells(Rows.Count, 2).End(xlUp).Row
    
    x = Evaluate("Sum(COUNTIF(B2:B" & ws1Row & ",{""*Remove*"",""*Change *"",""*Relocate*""}))")
    If x = 0 Then
        MsgBox "No Remove, Change or Relocation records found"
        Exit Sub
    End If
    
    For Each c In ws1.Range("B2:B" & ws1Row)
        If c.Value Like "*Remove*" Or _
            c.Value Like "*Change*" Or _
            c.Value Like "*Relocation*" Then
            ReDim Preserve arr(i)
            arr(i) = c.Value
            i = i + 1
        End If
    Next c
    
    With ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1Row, 13))
        .AutoFilter 2, Array(arr), 7
        .Offset(1).Resize(.Rows.Count - 1).Copy ws3.Cells(ws3Row, 1)
        .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        .AutoFilter
    End With
End Sub

 

[cns324]

Thank you again! If I wanted to split this up into 2 Marcos, would below be the best way? I have tested it, and it works, but I wanted to make sure I wasn't missing anything. Also I added a line to remove dups at the end of Stage 2.


Option Explicit
Option Compare Text
Sub cns324sub()
Dim ws1Row As Long, ws2Row As Long, ws3Row As Long, x As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, TestRng As Range
Set ws1 = Sheet1
Set ws2 = Sheets("Completed")
Set ws3 = Sheets("Review")

'1. Move the 'Completed' rows
ws1Row = ws1.Cells.Find("*", , xlFormulas, , 1, 2).Row
ws2Row = ws2.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1

With ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1Row, 13))
.AutoFilter 13, "Complete"
If ws1.Range("A1:A" & ws1Row).SpecialCells(12).Count = 1 Then
MsgBox "No Complete records found"
.AutoFilter
GoTo Stage2
End If
.Offset(1).Resize(.Rows.Count - 1).Copy ws2.Cells(ws2Row, 1)
.Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
.AutoFilter
End Sub

Sub Stage2()
Dim ws1Row As Long, ws2Row As Long, ws3Row As Long, x As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, TestRng As Range
Set ws1 = Sheet1
Set ws2 = Sheets("Completed")
Set ws3 = Sheets("Review")

'1. Move the other rows
Dim i As Long, c As Range, arr() As Variant
ws3Row = ws3.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
ws1Row = ws1.Cells(Rows.Count, 2).End(xlUp).Row

x = Evaluate("Sum(COUNTIF(B2:B" & ws1Row & ",{""*Remove*"",""*Change *"",""*Relocate*""}))")
If x = 0 Then
MsgBox "No Remove, Change or Relocation records found"
Exit Sub
End If

For Each c In ws1.Range("B2:B" & ws1Row)
If c.Value Like "*Remove*" Or _
c.Value Like "*Change*" Or _
c.Value Like "*Relocation*" Then
ReDim Preserve arr(i)
arr(i) = c.Value
i = i + 1
End If
Next c

With ws1.Range(ws1.Cells(1, 1), ws1.Cells(ws1Row, 13))
.AutoFilter 2, Array(arr), 7
.Offset(1).Resize(.Rows.Count - 1).Copy ws3.Cells(ws3Row, 1)
.Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
.AutoFilter
ws3.UsedRanage.RemoveDuplicates Columns:=5, Header:=xlYes
End Sub

 

[kevin9999]

I have tested it, and it works,

Interesting, because when I ran your code - it didn't.

In your (amended) Sub cns324sub(), change:

GoTo Stage2

to

Exit Sub

You're also missing an

End With

immediately before

End Sub

In your Sub Stage2() you misspelt

 ws3.UsedRanage.

should have been

ws3.UsedRange.

Also missing an

End With

immediately before

End Sub

Otherwise, it works fine