Excel宏 - 复制并粘贴已过滤的行 [英] Excel Macros - Copy and paste filtered rows

问题描述

因此，根据表格B中的下拉列表选项，我们要滚动浏览一行表格A，删除所有没有 Cell（4）= dropDownValue 的所有这些，然后复制该范围并粘贴到表 B。以下代码运行但不做任何事情。

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.

我可以调试并看到 dropDownValue 正确存储，而且 Cell（4）似乎可以正确地拉出它所循环的每一行。全新的VBA在这里，来自C＃背景，所以这似乎让我很困惑。

I can debug and see that the dropDownValue is 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.

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

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

推荐答案

是基于 我从你的帖子中提到的这一行中了解的内容

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

删除全部其中 不 有一个单元格（4）= dropDownValue

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

我的第一个问题是。

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

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

如果是文本，那么可以使用非常快的代码。它使用Autofilter而不是循环单元格。

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

这篇关于Excel宏 - 复制并粘贴已过滤的行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！