Excel Vba - 如果单元格中的值大于，则复制行

Excel Vba - Copy row if value in cell is greater than

提问by Kenny Bones

I've got this table full of data. And column K in each row contains a number. So basically what I'm trying to do is move that entire row, if the data in that column is greater than 9, over to sheet2.

我有一张充满数据的表格。每行中的 K 列包含一个数字。所以基本上我要做的是将整行移动到 sheet2，如果该列中的数据大于 9。

How can this be achieved? I've already created actual tables in the sheets, called Table1 and Table2.

如何做到这一点？我已经在工作表中创建了实际的表，称为 Table1 和 Table2。

This is what I've managed to put together so far. I've looked at autofilter, but I can't understand squat of what's happening in there. So this I get!

到目前为止，这是我设法组合在一起的。我看过自动过滤器，但我无法理解那里发生的事情。所以这我明白了！

Sub MoveData()

    Dim i As Range
    Dim num As Integer
     num = 1
    For Each i In Range("K10:K1000")
        If i.Value > 9 Then
            i.Select
            ActiveCell.Rows("1:1").EntireRow.Select
            Selection.Copy

            Sheets("Sheet2").Range("A65000").End(xlUp).Offset(num, 0).PasteSpecial
            ActiveCell.Rows.Delete
            num = num + 1

        End If
    Next i
End Sub

This kinda works so far. But I can't manage to paste the row to the next blank row in sheet2. I tried doing that num = num + 1 thing, but I guess that's way off?

到目前为止，这种方法有效。但是我无法将该行粘贴到 sheet2 中的下一个空白行。我试着做那个 num = num + 1 的事情，但我想那有点不对？

回答by Siddharth Rout

Is this what you are trying? (TRIED AND TESTED)

这是你正在尝试的吗？（久经考验）

Option Explicit

Sub Sample()
    Dim wsI As Worksheet, wsO As Worksheet
    Dim rRange As Range

    Dim lastRowWsO As Long

    Set wsI = Sheets("sheet1")

    '~~> Assuming that the Header is in K10
    Set rRange = wsI.Range("K10:K1000")

    Set wsO = Sheets("sheet2")

    '~~> Get next empty cell in Sheet2
    lastRowWsO = wsO.Range("A" & Rows.Count).End(xlUp).Row + 1

    With wsI
        '~~> Remove Auto Filter if any
        .AutoFilterMode = False

        With rRange
            '~~> Set the Filter
            .AutoFilter Field:=1, Criteria1:=">=9"

            '~~> Temporarirly hide the unwanted rows
            wsI.Rows("1:9").EntireRow.Hidden = True
            wsI.Rows("1001:" & Rows.Count).EntireRow.Hidden = True

            '~~> Copy the Filtered rows
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
            wsO.Rows(lastRowWsO)

            '~~> Delete The filtered rows
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With

        '~~> Unhide the rows
        .Rows("1:9").EntireRow.Hidden = False
        .Rows("1001:" & Rows.Count).EntireRow.Hidden = False

        '~~> Remove Auto Filter
        .AutoFilterMode = False
    End With
End Sub

NOTE: I have not included any error handling. I would recommend you to include one in the final code

注意：我没有包含任何错误处理。我建议您在最终代码中包含一个

FOLLOWUP

跟进

Sub Sample()
    Dim wsI As Worksheet, wsO As Worksheet
    Dim rRange As Range

    Dim lastRowWsI As Long, lastRowWsO As Long

    Set wsI = Sheets("Risikoanalyse")

    '~~> Assuming that the Header is in K10
    Set rRange = wsI.Range("K9:K1000")

    lastRowWsI = wsI.Cells.Find(What:="*", _
                After:=wsI.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row


    Set wsO = Sheets("SJA utarbeides")

    '~~> Get next empty cell in Sheet2
    lastRowWsO = wsO.Cells.Find(What:="*", _
                After:=wsO.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row + 1

    With wsI
        With .ListObjects("TableRisikoAnalyse")
            '~~> Set the Filter
            .Range.AutoFilter Field:=11, Criteria1:=">=9"

            '~~> Temporarirly hide the unwanted rows
            wsI.Rows("1:8").EntireRow.Hidden = True
            wsI.Rows(lastRowWsI & ":" & Rows.Count).EntireRow.Hidden = True

            '~~> Copy the Filtered rows
            wsI.Range(Replace(wsI.Range("K9").Offset(1, 0).SpecialCells(xlCellTypeVisible).Address, ":,", "")).EntireRow.Copy _
            wsO.Rows(lastRowWsO)

            '~~> Clear The filtered rows
            wsI.Range(Replace(wsI.Range("K9").Offset(1, 0).SpecialCells(xlCellTypeVisible).Address, ":,", "")).Clear

            .Range.AutoFilter Field:=11

            '~~> Sort the table so that blank cells are pushed down                
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=Range("TableRisikoAnalyse[[ ]]"), SortOn:=xlSortOnValues, Order _
            :=xlAscending, DataOption:=xlSortTextAsNumbers
            With .Sort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End With

        '~~> Unhide the rows
        .Rows("1:8").EntireRow.Hidden = False
        .Rows(lastRowWsI & ":" & Rows.Count).EntireRow.Hidden = False

        '~~> Remove Auto Filter
        .AutoFilterMode = False
    End With
End Sub