将基于多个标准的行从一个工作表复制到另一个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 

当使用多个片材它来限定的所有范围到它们各自的片材是很重要的。我已经用With Block和直接与范围做到了这一点。

此外，当仅发布值时，可以更简单地直接指定值而不是复制/粘贴。

此外，避免使用.Select或.Activate它会减慢代码。

我还设置了一个工作表变量到目标工作表，所以长线有点短。