Cut and Paste into a sheet with Case-Select - vba

Question

I am new to writing macros and trying to write one for work. Below is a piece of code I have been fighting with. I want it to look at sheet "NG304" and find key words listed in column B. If the key words are there, move them to the second spreadsheet "Payroll Detail". Issues i'm having - the code is not going through the whole list and it doesn't seem to be pasting in the next available row on the payroll detail spreadsheet (it will simply paste on top of my header).
Code:
Dim Findme As String, Findwhat As String, c As Range
With ActiveWorkbook.Worksheets("NG304")
For Each c In .Range(.Cells(2, "B"), .Cells(Rows.Count, "B").End(xlUp))
Findwhat = vbNullString
Findme = StrConv(c.Value2, vbProperCase)
Select Case True
Case Findme Like "VCIP"
Findwhat = "VCIP"
Case Findme Like "Company Labor"
Findwhat = UCase(Findme)
Case Else
'do nothing
End Select
If CBool(Len(Findwhat)) Then
With .Parent.Worksheets("NG304")
c.EntireRow.Cut Destination:=Worksheets("Payroll Detail").Range("A" & lastrow + 1)
lastrow = lastrow + 1
End With
End If
Next c
End With

Answer 1

This will filter each value defined in K_WORDS (at the top), and move the rows to the other sheet:
Option Explicit
Public Sub moveKeywordRows()
Const K_WORDS As String = "VCIP,Company Labor" '<------- Defined keywords
Dim wsFrom As Worksheet, wsDest As Worksheet, kw As Variant, i As Long, lr As Long
Set wsFrom = ThisWorkbook.Worksheets("NG304")
Set wsDest = ThisWorkbook.Worksheets("Payroll Detail")
kw = Split(K_WORDS, ",")
Application.ScreenUpdating = False
For i = 0 To UBound(kw)
lr = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Row
With wsFrom.UsedRange
.AutoFilter Field:=2, Criteria1:="=" & kw(i)
.Copy
wsDest.Cells(lr, "A").PasteSpecial xlPasteAll
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
Application.CutCopyMode = False
wsDest.Activate: wsDest.Cells(1, "A").Select
Next
wsDest.UsedRange.EntireColumn.AutoFit
With wsFrom
.Activate 'wsFrom.UsedRange.AutoFilter '.ShowAllData
End With
Application.ScreenUpdating = True
End Sub
This is your posted code, with some adjustments - it seems to be working:
Public Sub moveKeywordRows1()
Dim FindMe As String, FindWhat As String, c As Range, lr As Long, wsDest As Worksheet
Set wsDest = ThisWorkbook.Worksheets("Payroll Detail")
With ThisWorkbook.Worksheets("NG304")
Application.ScreenUpdating = False
For Each c In .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp))
FindMe = StrConv(c.Value2, vbProperCase)
FindWhat = vbNullString
Select Case UCase(FindMe)
Case "VCIP": FindWhat = "VCIP"
Case UCase("Company Labor"): FindWhat = "Company Labor"
End Select
If Len(FindWhat) > 0 Then
c.EntireRow.Cut Destination:=wsDest.Range("A" & lr + 1)
lr = lr + 1
End If
Next
Application.ScreenUpdating = True
End With
End Sub