Excel VBA - Copy and Paste Loop in VBA based on cell value - vba

Question

I am trying to come up with a macro that checks if any numeral value exists in a cell. If a numeral value exists, copy a portion of that row and paste it into another worksheet within the same spreadsheet.
Sheet1 is the sheet that has all my data in it. I am trying to look in column R if there is any values in it. If it does, copy that cell and the four adjacent cells to the left of it and paste it into Sheet2.
This is what I have come up with so far based on mish-mashing other people's code though it only does a part of what I want. It just copies part of a row then pastes it into another worksheet but it does not check column R for a value first. It just copies and pastes regardless and does not move onto the next row once it has done that. I need it to continue onto the next row to continue looking:
Sub Paste_Value_Test()
Dim c As Range
Dim IRow As Long, lastrow As Long
Dim rSource As Range
Dim wsI As Worksheet, wsO As Worksheet
On Error GoTo Whoa
'~~> Sheet Where values needs to be checked
Set wsI = ThisWorkbook.Sheets("Sheet1")
'~~> Output sheet
Set wsO = ThisWorkbook.Sheets("Sheet2")
Application.ScreenUpdating = False
With wsI
'~~> Find Last Row which has data in Col O to R
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastrow = .Columns("O:R").Find(What:="*", _
After:=.Range("O3"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lastrow = 1
End If
'~~> Set you input range
Set rSource = .Range("R" & lastrow)
'~~> Search for the cell which has "L" and then copy it across to sheet1
For Each c In rSource
Debug.Print cValue
If c.Value > "0" Then
.Range("O" & c.Row & ":R" & c.Row).Copy
wsO.Cells(5 + IRow, 12).PasteSpecial Paste:=xlPasteValues
IRow = IRow + 1
End If
Next
End With
LetsContinue:
Application.ScreenUpdating = True
Application.CutCopyMode = False
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub

Answer 1

Below is some code which hopefully achieves what I think you are trying to do. I have included comments throughout stating what I changed:
Sub Paste_Value_Test()
Dim c As Range
Dim IRow As Long, lastrow As Long
Dim rSource As Range
Dim wsI As Worksheet, wsO As Worksheet
On Error GoTo Whoa
'~~> Sheet Where values needs to be checked
Set wsI = ThisWorkbook.Sheets("Sheet1")
'~~> Output sheet
Set wsO = ThisWorkbook.Sheets("Sheet2")
Application.ScreenUpdating = False
With wsI
'~~> Find Last Row which has data in Col O to R
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
'You specified "After" to be cell O3. This means a match will
' occur on row 2 if cell R2 (or O2 or P2) has something in it
' because cell R2 is the cell "after" O3 when
' "SearchDirection:=xlPrevious"
' After:=.Range("O3"), _
lastrow = .Columns("O:R").Find(What:="*", _
After:=.Range("O1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lastrow = 1
End If
'This was only referring to the single cell in column R on the
' last row (in columns O:R)
'Set rSource = .Range("R" & lastrow)
'Create a range referring to everything in column R, from row 1
' down to the "last row"
Set rSource = .Range("R1:R" & lastrow)
'This comment doesn't seem to reflect what the code was doing, or what the
'question said
'~~> Search for the cell which has "L" and then copy it across to sheet1
For Each c In rSource
'This is printing the variable "cValue", which has never been set
'Debug.Print cValue
'It was probably meant to be
Debug.Print c.Value
'This was testing whether the value in the cell was
' greater than the string "0"
'So the following values would be > "0"
' ABC
' 54
' ;asd
'And the following values would not be > "0"
' (ABC)
' $523 (assuming that was as text, and not just 523 formatted as currency)
'If c.Value > "0" Then
'I suspect you are trying to test whether the cell is numeric
' and greater than 0
If IsNumeric(c.Value) Then
If c.Value > 0 Then
'This is only copying the cell and the *three* cells
' to the left of it
'.Range("O" & c.Row & ":R" & c.Row).Copy
'This will copy the cell and the *four* cells
' to the left of it
'.Range("N" & c.Row & ":R" & c.Row).Copy
'wsO.Cells(5 + IRow, 12).PasteSpecial Paste:=xlPasteValues
'But this would avoid the use of copy/paste
wsO.Cells(5 + IRow, 12).Resize(1, 5).Value = _
.Range("N" & c.Row & ":R" & c.Row).Value
IRow = IRow + 1
End If
End If
Next
End With
LetsContinue:
Application.ScreenUpdating = True
Application.CutCopyMode = False
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub