Vba 基于范围中的特定值复制和粘贴行

因此，我有以下代码，可以根据组合框的输入复制和粘贴单元格，我想知道如何调整它以复制整行而不仅仅是单元格：

Dim K As Long, r As Range, v As Variant
K = 1
Dim w1 As Worksheet, w2 As Worksheet
Set w1 = Sheets("RAW Data")
Set w2 = Sheets("Output")
w1.Activate
For Each r In Intersect(Range("D5:D1048576"), ActiveSheet.UsedRange)
    v = r.Value
    If InStr(v, ModelSelection.Value) > 0 Then
        r.Copy w2.Cells(K, 1)
        K = K + 1
    End If
Next r

更改：

r.Copy w2.Cells(K, 1)

致：

未激活

w1

工作表的

的整个代码：

With w1
    For Each r In Intersect(.Range("D5:D1048576"), .UsedRange)
        v = r.Value
        If InStr(v, ModelSelection.Value) > 0 Then
            r.EntireRow.Copy w2.Cells(K, 1)
            K = K + 1
        End If
    Next r
End With


注意：一种更快的方法不是多次复制>>粘贴，而是使用
CopyRng
对象，它将保存所有符合条件的合并
r
，然后在最后只复制>>粘贴一次（也不需要提前
K
）

修改代码

您还可以使用
AutoFilter（）
：

太棒了，谢谢。如何定义从特定单元格开始的输出，例如粘贴单元格c3中的内容？@AaronGretton将
w2.Cells（1,1）
更改为
w2.Range（“c3”）
谢谢，尽管我在哪一行得到错误“403 object required”@AaronGretton？请稍后返回原始代码，我尝试添加一个标题行，并将其与其他数据一起复制粘贴：
Dim K As Long，r As Range，v As Variant，title As String，titlerow As Integer K=1 Dim w1 As Worksheet，w2 As Worksheet w1=Sheets（“原始数据”）Set w2=Sheets（“输出”）w1。激活title=“A4:AO4”titlerow=ws.Range（title）.Cells（1）.Row
这实际上更快，尽管列表中有>20k项-它们都可以通过此方法拾取吗？好吧，试试吧！还有没有办法指定输出的位置（例如单元格d2）是的，只需更改
。单元格（1，1）< /代码>到您需要的任何位置。如果我的答案解决了您的问题，您可以考虑将其标记为“接受”。谢谢。我复制行时，不允许我将输出更改为“大小不一样”的区域。
With w1
    For Each r In Intersect(.Range("D5:D1048576"), .UsedRange)
        v = r.Value
        If InStr(v, ModelSelection.Value) > 0 Then
            r.EntireRow.Copy w2.Cells(K, 1)
            K = K + 1
        End If
    Next r
End With

Dim CopyRng As Range

With w1
    For Each r In Intersect(.Range("D5:D1048576"), .UsedRange)
        v = r.Value
        If InStr(v, ModelSelection.Value) > 0 Then
            If Not CopyRng Is Nothing Then
                Set CopyRng = Application.Union(r, CopyRng)
            Else
                Set CopyRng = r
            End If
        End If
    Next r
End With

' Copy >> Paste only once of the entire range
If Not CopyRng Is Nothing Then CopyRng.EntireRow.Copy w2.Cells(1, 1)

With Sheets("RAW Data")
    With .Range("D4", .Cells(.Rows.count, "D").End(xlUp))
        .AutoFilter field:=1, Criteria1:="*" & Me.ModelSelection.Value & "*"
        With .Resize(.Rows.count - 1, .Columns.count).Offset(1, 0)
            If CBool(Application.Subtotal(103, .Cells)) Then Intersect(.Parent.UsedRange, .SpecialCells(xlCellTypeVisible).EntireRow).Copy Sheets("Output").Cells(1, 1)
        End With
    End With
    .AutoFilterMode = False
End With