CODEWITHSUNDEEP
excelvbacopyrow
edorius
edorius

Reputation: 71

Check cell value, copy when matching

I have a constantly growing list.

If a certain cell value is greater than 10, the whole row should be copied into a certain worksheet. If the value is 10 or smaller, the next row should be checked, until the last row containing data is reached.

This is my current macro. It copies the rows to the same locations like before. I need them to be listed without free space.

Sub Copy()
Dim s1 As Worksheet, s2 As Worksheet
Dim N As Long, i As Long, j As Long
Set s1 = Sheets("Hours")
Set s2 = Sheets("Check")
N = s1.Cells(Rows.Count, "R").End(xlUp).Row
j = 1
For i = 1 To N
    If s1.Cells(i, "R").Value > "10" Then
       s1.Cells(i, "R").EntireRow.Copy s2.Cells(j, 1)
        j = j + 1
    End If
Next i
End Sub

Upvotes: 1

Views: 482

Answers (2)

Shai Rado
Shai Rado

Reputation: 33692

I tried not to move away from your original code (even though using AutoFilter method was quite Tempting)

I think your error was due to not fully qualify the way you are looking for N (last row); You used N = s1.Cells(Rows.Count, "R").End(xlUp).Row, and if the ActiveSheet is another sheet then you would get a different value for Rows.Count. I just added the worksheet reference N = s1.Cells(s1.Rows.Count, "R").End(xlUp).Row

I added another "safety" criteria, in case you have a text in column "R", I've modifed your If criteria to 'If IsNumeric(s1.Range("R" & i)) And s1.Range("R" & i).Value > 10 Then`

Code

Sub Copy()

Dim s1 As Worksheet, s2 As Worksheet
Dim N As Long, i As Long, j As Long

Set s1 = Sheets("Hours")
Set s2 = Sheets("Check")

N = s1.Cells(s1.Rows.Count, "R").End(xlUp).Row
j = 1
For i = 1 To N
    If IsNumeric(s1.Range("R" & i)) And s1.Range("R" & i).Value > 10 Then
        s1.Cells(i, "R").EntireRow.Copy s2.Cells(j, 1)
        j = j + 1
    End If
Next i

End Sub

Upvotes: 0

F.Igor
F.Igor

Reputation: 4390

You can do a post-process when finished the current script, deleting the empty rows (change the range "C50" to the max range of column/row to check empty):

  dim r As Range, rows As Long, i As Long
  Set r = Sheets("Check").Range("A1:C5000")
  rows = r.rows.Count
  For i = rows To 1 Step (-1)
    If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
  Next

Upvotes: 1

Related Questions