If cell A1 is greater than B1, cut and paste row to first empty row

user_13893948 0
Viewed 142

If cell in column I1-I14 is greater than cell in column J1-J14, I want to cut the entire row and paste values to the first empty row. (From row 16 and down.)

If cell i is greater than cell j, cut row and paste values to first empty row (row 16 in this example)
enter image description here

This code just pastes in the first row:

Sub Knapp6_Klicka()
    
    Dim i As Long
    Dim j As Long
    
    j = 1
    For i = 3 To 500
        If Cells(i, 9).Value > Cells(i, 10).Value Then
            Cells(i, 12).EntireRow.Cut Sheets("Blad1").Range("A" & j)
        j = j + 1
        End If
    Next i
        
End Sub

I tried to combine the paste with two different solutions.

One like this, where I recorded a macro and went to the last cell, then up to the first empty cell:

Range("A1048576").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
Application.CutCopyMode = False

And one solution that I found on an Excel community:

Sub compareresult()
    
    Dim row1 As Integer
    Dim row2 As Integer
    
    row2 = 1
    For row1 = 8 To 500
        If sheet1.Cells(row1, 11).value > sheet1.Cells(row1, 9).value Then
            sheet1.Cells(row1, 1).EntireRow.Copy Sheets(11).Cells(row2, 1)
            row2 = row2 + 1
        End If
    Next row1
    
End Sub
vba excel
3 Answers

If cell in column I1-I14 is greater than cell in column J1-J14, i want to cut entire row and paste values to the first empty row. (From row 16 and down)

Here is a method which doesn't cut and paste in a loop. Since you are not deleting the row or "cutting and inserting" the row, here is a simple approach. The below code follows a basic logic

Logic

  1. Loop and identify the range.
  2. If found, then copy the range in 1 go.
  3. Finally clear the range which was copied (if copied).

Code

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim rngToCopy As Range
    Dim i As Long
    
    '~~> Change this to relevant sheet
    Set ws = Sheet1
    
    With ws
        '~~> Loop and identify the range
        For i = 2 To 14
            If .Range("I" & i).Value2 > .Range("J" & i).Value2 Then
                If rngToCopy Is Nothing Then
                    Set rngToCopy = .Rows(i)
                Else
                    Set rngToCopy = Union(rngToCopy, .Rows(i))
                End If
            End If
        Next i
        
        '~~> If found then copy and clear
        If Not rngToCopy Is Nothing Then
            rngToCopy.Copy .Rows(16)
            rngToCopy.Clear
        End If
    End With
End Sub

EDIT:

To incorporate new edits

Works perfectly! Thanks! :) I failed to fully describe my problem.. What i also need is to paste it as special (only paste the value and not the formulas). Do you got any quick solution for that? – Johl 5 hours ago

Replace

rngToCopy.Copy .Rows(16)

to

rngToCopy.Copy
DoEvents
.Rows(16).PasteSpecial Paste:=xlPasteValues
user_11405790

Have a try with this.

It's based on the range you gave. Skipped over row 1 since you have headers in it.

Dim i As Long, lRow As Long, ws As Worksheet

Set ws = Sheets("Blad1") 'Your sheet name
lRow = ws.Range("I" & Rows.Count).End(xlUp).Row + 1 'Finding the last row
If lRow < 16 Then lRow = 16 'The starting row you want to cut to

For i = 2 To 14 'Your range of rows to check
    If ws.Range("I" & i) > ws.Range("J" & i) Then
        ws.Range("I" & i).EntireRow.Cut ws.Range("A" & lRow) 'Cutting the whole row so you use column A to cut to
        lRow = lRow + 1 'Move down 1 row for where to cut to
    End If
Next i

Edit:

Because you only want the values to copy accross we can't use Cut and PasteSpecial xlValues so instead we will duplicate the value of the entire row to the new location, then clear the row (filling in for the cutting part). If clear is too much we can just ClearContents to remove the values in the cells instead of the formatting if that happens. Make sure to always save before running VBA code for the first time.

Dim i As Long, lRow As Long, ws As Worksheet

Set ws = Sheets("Blad1") 'Your sheet name
lRow = ws.Range("I" & Rows.Count).End(xlUp).Row + 1 'Finding the last row
If lRow < 16 Then lRow = 16 'The starting row you want to cut to

For i = 2 To 14 'Your range of rows to check
    If ws.Range("I" & i) > ws.Range("J" & i) Then
        ws.Range("A" & lRow).EntireRow.Value = ws.Range("I" & i).EntireRow.Value 'Copying the values over
        ws.Range("I" & i).EntireRow.Clear 'Clear the row
        lRow = lRow + 1 'Move down 1 row for where to cut to
    End If
Next i
user_26321650

Your code is doomed to failure because you do not take into consideration that you are cutting the found row. Think about what that means. Your row with the In,Out is row 15 and you wish to paste to row 16. If you cut row 5 (for example) then rows 15 and 16 will become rows 14 and 15. It also means that your next row (which you think will be row 6) will actually be what was row 7 before the cut.

user_71773460
Related