Question

因此，根据工作表"B"中的下拉菜单选择，我们想要滚动工作表"A"中的一堆行，删除所有不具有{{1}的行然后复制该范围并将其粘贴到工作表Cell(4) = dropDownValue中。下面的代码运行但没有做任何事情。

我可以调试并看到"B"被正确存储，并且dropDownValue似乎在它循环的每一行都被正确拉出。这里来自VBA全新，来自C＃背景，所以这对我来说似乎很混乱。

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

Cell(4)

Answer 1

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

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

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

注意B ：循环没问题，但是如果你想提高效率或者要搜索很多行，那么不要使用公式然后删除循环使用autofilter，然后删除可见行。

注意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

Answer 2

我的回复是根据我在您的帖子中提到的这条线理解的内容

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

我的第一个问题是。

您在Col E中有哪些数据？数字还是文字？

如果是文本，那么你可以使用这个非常快的代码。它使用“自动过滤”而不是循环细胞。

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

Excel宏 - 复制并粘贴已过滤的行

2 个答案: