Копирование строк на основе нескольких критериев с одного рабочего листа на другой VBA

Question

Я пытаюсь скопировать строки из листа инвентаря на лист Fruit, но приведенные ниже коды сохраняют копию и вставку на том же листе. Я понятия не имею, как это изменить. Может кто-то мне помочь, пожалуйста? Заранее благодарю за любую помощь!!

Sub FruitBasket() 

Dim rngCell As Range 
Dim lngLstRow As Long 
Dim strFruit() As String 
Dim intFruitMax As Integer 


intFruitMax = 3 
ReDim strFruit(1 To intFruitMax) 


strFruit(1) = "Fruit 2" 
strFruit(2) = "Fruit 5" 
strFruit(3) = "Fruit 18" 

lngLstRow = ActiveSheet.UsedRange.Rows.Count 

For Each rngCell In Range("A2:A" & lngLstRow) 
    For i = 1 To intFruitMax 
     If strFruit(i) = rngCell.Value Then 
      rngCell.EntireRow.Copy 
      Sheets("Inventory").Select 
      Range("A65536").End(xlUp).Offset(1, 0).Select 
      Selection.PasteSpecial xlPasteValues 
      Sheets("Fruit").Select 
     End If 
    Next i 
Next 

End Sub 

Answer 1

Альтернативный метод с использованием автофильтра во избежание возникновения цикла. Комментировать для наглядности:

Sub tgr() 

    Dim wsData As Worksheet 
    Dim wsDest As Worksheet 
    Dim aFruit() As String 

    Set wsData = Sheets("Inventory") 'Copying FROM this worksheet (it contains your data) 
    Set wsDest = Sheets("Fruit")  'Copying TO this worksheet (it is your destination) 

    'Populate your array of values to filter for 
    ReDim aFruit(1 To 3) 
    aFruit(1) = "Fruit 2" 
    aFruit(2) = "Fruit 5" 
    aFruit(3) = "Fruit 18" 

    With wsData.Range("A1", wsData.Cells(wsData.Rows.Count, "A").End(xlUp)) 
     .AutoFilter 1, aFruit, xlFilterValues 'Filter using the array, this avoids having to do a loop 

     'Copy the filtered data (except the header row) and paste it as values 
     .Offset(1).EntireRow.Copy 
     wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues 
     Application.CutCopyMode = False  'Remove the CutCopy border 
     .AutoFilter  'Remove the filter 
    End With 

End Sub 

Answer 2

Попробуйте это:

Sub FruitBasket() 

Dim rngCell As Range 
Dim lngLstRow As Long 
Dim strFruit() As String 
Dim intFruitMax As Integer 
Dim tWs As Worksheet 

intFruitMax = 3 
ReDim strFruit(1 To intFruitMax) 

Set tWs = Sheets("Inventory") 
strFruit(1) = "Fruit 2" 
strFruit(2) = "Fruit 5" 
strFruit(3) = "Fruit 18" 

With Sheets("Fruit") 

    lngLstRow = .Range("A" & .Rows.Count).End(xlUp) 

    For Each rngCell In .Range("A2:A" & lngLstRow) 
     For i = 1 To intFruitMax 
      If strFruit(i) = rngCell.Value Then 
       tWs.Rows(tWs.Range("A" & tWs.Rows.Count).End(xlUp).Offset(1, 0).Row).Value = .Rows(rngCell.Row).Value 
      End If 
     Next i 
    Next 
End With 
End Sub 

При использовании нескольких листов, важно, чтобы квалифицировать все диапазоны их соответствующего листа. Я сделал это с помощью блока «С» и напрямую с диапазонами.

Также, когда вы отправляете только значения, проще просто назначить значения непосредственно вместо копирования/вставки.

Кроме того, избегайте использования .Select или .Activate, это замедлит код.

Я также установил переменную рабочего листа на целевой лист, так что длинная линия немного короче.