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 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，这会降低代码速度。

我还将工作表变量设置为目标工作表，因此长行稍短。

Answer 2

使用自动过滤器的备用方法以避免出现循环。为清晰起见评论：

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

将基于多个条件的行从一个工作表复制到另一个VBA

2 个答案: