Excel Vba - Копировать строку, если значение в ячейке больше

Question

У меня есть таблица, полная данных. И столбец K в каждой строке содержит число. Поэтому в основном то, что я пытаюсь сделать, - это перемещение всей строки, если данные в этом столбце больше 9, до листа2.

Как это можно достичь? Я уже создал фактические таблицы в листах, называемые Table1 и Table2.

Это то, что мне удалось собрать до сих пор. Я посмотрел на автофильтр, но я не могу понять, что происходит там. Так вот я и получаю!

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 

Этот вид работает до сих пор. Но мне не удастся вставить строку в следующую пустую строку в sheet2. Я попытался сделать это num = num + 1 вещь, но я думаю, что это далеко?

Answer 1

Это то, что вы пытаетесь? (испытанный)

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 

ПРИМЕЧАНИЕ: Я не включил любой обработки ошибок. Я бы рекомендовал вам включить один в окончательном коде

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, "$9:$9,", "")).EntireRow.Copy _ 
      wsO.Rows(lastRowWsO) 

      '~~> Clear The filtered rows 
      wsI.Range(Replace(wsI.Range("K9").Offset(1, 0).SpecialCells(xlCellTypeVisible).Address, "$9:$9,", "")).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