1つのワークシートから複数のVBAに複数の条件に基づいて行をコピー

Question

在庫シートからフルーツシートに行をコピーしようとしていますが、以下のコードは同じシートにコピーして貼り付けます。私はこれをどのように変更するのか分かりません。誰かが私を助けることができますか？助けてくれてありがとう！

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を使用するとコードが遅くなることは避けてください。

また、対象シートにワークシート変数を設定して、長い行が少し短くなるようにしました。