我需要此代码来一次将多行移动到新工作表中
我需要此代码来一次将多行移动到新工作表中
提问于 2019-07-26 02:56:43
下面的代码将单行移动到新的工作表，但我需要它来移动所有它们。例如，我会有11-1，11-2，11-3，12-1，12-2，12-3等等，它需要一次移动所有的11。
Sub Findandcut()
Dim rw As Long
Dim lastrow As Long
For rw = 1000 To 2 Step -1
lastrow = Worksheets("Sheet2").UsedRange.Rows(Worksheets("Sheet2").UsedRange.Rows.Count).row
With Worksheets("Sheet1")
' Check if "save" appears in the value anywhere.
If .Cells(rw, 1).Value Like "*11*" Then
' Cut the value and then blank the source and shift up
.Cells(rw, 2).EntireRow.Cut Destination:=Worksheets("Sheet2").Cells(lastrow, 1)
'.Cells(rw, 2).EntireRow.Delete (xlUp)
End If
End With
Next
End Sub回答 1
Stack Overflow用户
发布于 2019-07-26 03:40:22
我们不是为每个单元格查找、复制和粘贴，而是首先获取匹配给定条件的所有行的并集，然后只复制和粘贴一次。然后，我们可以从Sheet1中删除所有这些行。这既快又高效
Sub Findandcut()
Dim rw As Long, lastrow As Long, MySel As Range
With Worksheets("Sheet1")
For rw = 1000 To 2 Step -1
If .Cells(rw, 1).Value Like "*11*" Then
If MySel Is Nothing Then
Set MySel = .Cells(rw, 1).EntireRow
Else
Set MySel = Union(MySel, .Cells(rw, 1).EntireRow)
End If
End If
Next rw
End With
With ThisWorkbook.Worksheets("Sheet2")
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
If Not MySel Is Nothing Then
MySel.Copy Destination:= .Cells(lastrow+1, 1)
MySel.Delete
End If
End With
End Sub页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/57208568
复制相关文章
相似问题
腾讯云开发者
