vba Excel 宏 - 复制和粘贴过滤的行

Excel Macros - Copy and paste filtered rows

提问by slandau

So based off of a dropdown selection in sheet "B", we want to scroll through a bunch of rows in sheet "A", delete all of them that don't have a Cell(4) = dropDownValue, and then copy that range and paste it into sheet "B". The code below runs but doesn't do anything.

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

I can debug and see that the dropDownValueis stored correctly, and also that the Cell(4)seems to get pulled correctly for every row it loops through. Brand new to VBA here, coming from a C# background, so this seems very confusing to me.

我可以调试并看到它的dropDownValue存储是否正确，并且Cell(4)似乎对于它循环的每一行都被正确拉出。这里是 VBA 的新手，来自 C# 背景，所以这对我来说似乎很混乱。

Any ideas on how to fix this or what I'm doing wrong?

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

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

采纳答案by Siddharth Rout

My reply is based on what I understood from this line which you mentioned in your post

我的回复是基于我从您在帖子中提到的这一行中了解到的

delete all of them that don'thave a Cell(4) = dropDownValue

删除所有没有Cell(4) = dropDownValue

My First question would be.

我的第一个问题是。

What kind of data do you have in Col E? Numbers or Text?

你在Col E有什么样的数据？数字还是文字？

If it is text then you can use this code which is very fast. It uses "Autofilter" rather than looping the cells.

如果是文本，那么您可以使用此代码，速度非常快。它使用“自动过滤器”而不是循环单元格。

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

And if it is numbers then use this

如果它是数字然后使用这个

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

回答by Reafidy

When deleting rows like that you need to work backwards. Try:

删除这样的行时，您需要向后工作。尝试：

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

NOTE A: In VBA all dimensioning should be at the top of the module.

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

NOTE B: Looping is okay but if you want to improve efficiency or you have many rows to search then instead of looping use autofilter with a formula and then delete visible rows.

注意 B：循环是可以的，但是如果您想提高效率或者有很多行要搜索，那么不要循环使用带有公式的自动过滤器，然后删除可见行。

NOTE C: When working with rows use long instead of integer to prevent overflow so in your case:

注意 C：在处理行时使用 long 而不是 integer 以防止溢出，因此在您的情况下：

Dim i As Long

NOTE D: As Tim mentioned above.

注意 D：正如上面提到的蒂姆。

Here is some changes which might help:

以下是一些可能有所帮助的更改：

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

Example of the autofilter method:

自动过滤方法示例：

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