Excelmacros – 复制和粘贴过滤的行

因此，基于表单"B"中的下拉select，我们要滚动表格"A"的一堆行，删除所有没有Cell(4) = dropDownValue ，然后复制该范围并粘贴到"B" 。 下面的代码运行，但没有做任何事情。

我可以debugging，并看到dropDownValue正确存储，并且也似乎Cell(4)似乎得到拉正确的每一行它循环。 VBA这里是全新的，来自C＃背景，所以这对我来说似乎很混乱。

任何想法如何解决这个问题或我做错了什么？

 Sheets("B").Select Dim dropDownValue As String dropDownValue = Left(Range("L1").Value, 3) Dim wantedRange As Range Dim newRange As Range Dim cell As Object Dim i As Integer Set wantedRange = Sheets("A").Range("E11:E200") For i = 1 To wantedRange.Rows.Count Step 1 Dim target As String target = wantedRange.Rows(i).Cells(4) If Not (target Like dropDownValue) Then wantedRange.Rows(i).Delete End If Next i Sheets("B").Select Application.CutCopyMode = False wantedRange.copy Selection.wantedRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 

Answer 1

我的回复是基于你在你的post中提到的这一行所理解的

删除所有没有 Cell（4）= dropDownValue的

我的第一个问题是。

Col E有什么样的数据？ 数字或文字？

如果是文本，那么你可以使用这个非常快的代码。 它使用“自动filter”而不是循环单元格。

 Option Explicit Sub Sample() Dim ws1 As Worksheet, ws2 As Worksheet Dim LookupVal As String Dim ws1rng As Range, toCopyRange As Range On Error GoTo Whoa Application.ScreenUpdating = False Set ws1 = Sheets("A") Set ws2 = Sheets("B") LookupVal = "<>*" & Left(ws2.Range("L1").Value, 3) & "*" Set ws1rng = ws1.Range("E11:E200") ws1.AutoFilterMode = False With ws1rng .AutoFilter Field:=1, Criteria1:=LookupVal, Operator:=xlAnd Set toCopyRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible) End With ws1.AutoFilterMode = False '~~> Will copy the data to Sheet B cell A20 toCopyRange.Copy ws2.Range("A20") LetsContinue: Application.ScreenUpdating = True Exit Sub Whoa: MsgBox Err.Description Resume LetsContinue End Sub 

如果是数字，那就用这个

 Option Explicit Sub Sample() Dim sDropDown As String Dim lRowCnt As Long, i As Long Dim delRange As Range On Error GoTo Whoa Application.ScreenUpdating = False sDropDown = Left(Sheets("B").Range("L1").Value, 3) With Sheets("A").Range("E11:E200") '<~~ Modified Reafidy's code :) For lRowCnt = .Rows.Count To 1 Step -1 If (.Rows(lRowCnt).Value Like "*" & sDropDown & "*") Then If delRange Is Nothing Then Set delRange = .Rows(lRowCnt) Else Set delRange = Union(delRange, .Rows(lRowCnt)) End If End If Next lRowCnt If Not delRange Is Nothing Then delRange.Delete End If lRowCnt = Sheets("A").Range("E" & Rows.Count).End(xlUp).Row '~~> Will copy the data to Sheet B cell A20 Sheets("A").Range("E11:E" & lRowCnt).Copy Sheets("B").Range("A20") End With LetsContinue: Application.ScreenUpdating = True Exit Sub Whoa: MsgBox Err.Description Resume LetsContinue End Sub 

Answer 2

当删除这样的行时，你需要反向工作。 尝试：

 For i = wantedRange.Rows.Count To 1 Step -1 

注意A ：在VBA中，所有的尺寸都应该在模块的顶部。

注意B ：循环是可以的，但是如果你想提高效率，或者你有很多的行来search，而不是循环使用自动filter和公式，然后删除可见的行。

注意C ：当使用行使用long而不是整数来防止溢出，所以在你的情况下：

 Dim i As Long 

注释D ：如上面提到的那样。

以下是可能有所帮助的一些变化：

 Dim sDropDown As String Dim lRowCnt As Long sDropDown = Left(Sheets("B").Range("L1").Value, 3) With Sheets("A").Range("E11:E200") For lRowCnt = .Rows.Count To 1 Step -1 If Not (.Rows(lRowCnt).Value Like "*" & sDropDown "*") Then .Rows(lRowCnt).Delete End If Next i Sheets("B").Resize(.Rows.Count, .Columns.Count).Value = .Value End With 

自动过滤方法的示例：

 Dim sFilter As String sFilter = "<>*" & Left(Sheets("B").Range("L1").Value, 3) & "*" Application.ScreenUpdating = False With Sheets("A").Range("E11:E200") .Offset(-1, 0).Resize(.Rows.Count + 1).AutoFilter Field:=1, Criteria1:=sFilter, Operator:=xlAnd .EntireRow.Delete .Parent.AutoFilterMode = False Sheets("B").Cells(1, 1).Resize(.Rows.Count, 1).Value = .Value '// Output End With Application.ScreenUpdating = True