excel - 如果单元格 A1 大于 B1，则将行剪切并粘贴到第一个空行

Question

如果 I1-I14 列中的单元格大于 J1-J14 列中的单元格，我想剪切整行并将值粘贴到第一个空行。 (从第 16 行开始。)

如果单元格 i 大于单元格 j，则剪切行并将值粘贴到第一个空行(本例中为第 16 行)

此代码仅粘贴在第一行:

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

我尝试将浆糊与两种不同的解决方案结合起来。

像这样，我记录了一个宏并转到最后一个单元格，然后转到第一个空单元格:

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

以及我在 Excel 社区中找到的一个解决方案:

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

Answer 1

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)

这是一种不循环剪切和粘贴的方法。由于您不是删除该行或“剪切和插入”该行，因此这里有一个简单的方法。下面的代码遵循基本逻辑

逻辑

1. 循环并确定范围。
2. 如果找到，则一次性复制该范围。
3. 最后清除复制的范围(如果复制的话)。

代码

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

编辑:

合并新的编辑

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

替换

rngToCopy.Copy .Rows(16)

至

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