Cut Values and Paste to another column based on criteria

[tranzeodude]

My spreadsheet has 'Hours Worked' under column F and 'Pay Code' under column G.
What I want to do is whenever there are '601', '603', '17' under column G 'Pay Code', I want to cut/paste values from column F 'Hours Worked' to column K.

Below is my code which is partially working (it does moved based on the pay codes that I indicated but it is moving 'column G - Pay Code' instead of 'column F - hours worked' that I needed!):

Sub Macro1()
'
'
Dim rngA As Range
Dim rngB As Range
Dim cell As Range

Set rngA = Sheets("Employee Hours").Range("G2:G20")
Set rngB = Sheets("Employee Hours").Range("F2:F20")

For Each cell In rngA
If cell.Value = "601" Or cell.Value = "603" Or cell.Value = "17" Then
ActiveCell.Offset(0, 5).Range("A1").Select
Cells.Copy cell.Offset(0, 4)
Cells.Clear
End If
Next cell
'
End Sub

Please help.

 

[mrhstn]

Hi

I think a simple numeric loop would achieve the result a bit easier

Sub Macro1()
Dim i As Integer
Dim MyCodes As String
Dim lstK As Long


MyCodes = "|601|603|17|"


With Sheets("Employee Hours")
    For i = 2 To 20
    
        If InStrRev(MyCodes, "|" & .Range("G" & i) & "|") > 0 Then
            lstK = .Range("K" & Rows.Count).End(xlUp).Row + 1
            .Range("K" & lstK) = .Range("F" & i)
        End If
    
    Next i
End With


End Sub

 

[tranzeodude]

Thanks but it doesn't do exactly like I intended.


What I want to achieve is to for each row under column G - Pay Code, only move the numbers from column F - hours worked to column K if they contains 601 or 603 or 17.
If no match, then nothing need to be done. Your code seems to move the first 3 rows and nothing happened after that even though there's a match.

Hi

I think a simple numeric loop would achieve the result a bit easier

Sub Macro1()
Dim i As Integer
Dim MyCodes As String
Dim lstK As Long


MyCodes = "|601|603|17|"


With Sheets("Employee Hours")
    For i = 2 To 20
    
        If InStrRev(MyCodes, "|" & .Range("G" & i) & "|") > 0 Then
            lstK = .Range("K" & Rows.Count).End(xlUp).Row + 1
            .Range("K" & lstK) = .Range("F" & i)
        End If
    
    Next i
End With


End Sub

 

[mrhstn]

Can you post what your data looks like to start with and the expected result. Thanks

 

[tranzeodude]

See below screenshot:
https://imgur.com/a/Kl16o6W

Only rows that contains 603/601/17 (column G - Pay Code) will have their hours worked moved from column F (Hours Worked) to column K (LS Amount).
Hope this makes sense.

 

[mrhstn]

Looks like In range G2:G20 (as defined in your code there is only one instance of each 17, 601 and 603 so my code works just fine.

 

[My Aswer Is This]

Try this:

Sub Hours()
'Modified  7/23/2018  6:32:11 PM  EDT
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Sheets("Employee Hours").Activate
Lastrow = Cells(Rows.Count, "G").End(xlUp).Row
For i = 1 To Lastrow
MyVal = Cells(i, "G").Value
With Cells(i, "G")
            Select Case MyVal
                Case "601", "603", "17"
                    Cells(i, "G").Offset(, -1).Copy Cells(i, "G").Offset(, 4): Cells(i, "G").Offset(, -1).ClearContents
            End Select
End With
Next
Application.ScreenUpdating = True
End Sub

 

[tranzeodude]

That works out perfect!
Thank you for your help!

 

[My Aswer Is This]

Glad I was able to help you.
Come back here to Mr. Excel next time you need additional assistance.

That works out perfect!
Thank you for your help!

 

[tranzeodude]

Absolutely! Very helpful site!

Glad I was able to help you.
Come back here to Mr. Excel next time you need additional assistance.