[英]Copy Rows Based On Multiple Criteria from one Worksheet to Another VBA
I'm trying to copy rows from Inventory sheet to Fruit sheet, but the codes below keeps copy and pasting in the same sheet. 我试图将行从库存表复制到水果表,但是下面的代码将复制和粘贴保留在同一表中。 I have no idea how to change this.
我不知道该如何更改。 Can someone help me please?
有人能帮助我吗? thanks in advance for any help!!
在此先感谢您的帮助!
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
Try this: 尝试这个:
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
When using multiple sheets it is important to qualify all ranges to their respective sheet. 当使用多张纸时,重要的是使所有范围限定在各自的纸上。 I have done this with the With Block and directly with the ranges.
我已经使用With Block并直接使用范围完成了此操作。
Also when only posting values it is quicker to simple assign the values directly instead of copy/paste. 同样,当仅发布值时,直接分配值而不是复制/粘贴更加快捷。
Also, avoid using .Select
or .Activate
it will slow down the code. 另外,避免使用
.Select
或.Activate
会减慢代码速度。
I also set a worksheet variable to the target sheet so the long line is a little shorter. 我还为目标工作表设置了一个工作表变量,因此长线短了一点。
Alternate method using autofilter to avoid having a loop. 使用自动过滤器的另一种方法,以避免产生循环。 Commented for clarity:
为清楚起见,评论如下:
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.