Question

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

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

Answer 1

变化：

r.Copy w2.Cells(K, 1)

要：

r.EntireRow.Copy w2.Cells(K, 1)

没有Activate工作表的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

注意：更快的方法是复制＆gt;＆gt;粘贴这么多次，但使用CopyRng对象，这将保存符合条件的所有合并r，然后最后只复制＆gt;＆gt;粘贴一次（也不需要提前K）。

修改后的代码

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)

Answer 2

你也可以使用AutoFilter()：

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

根据范围中的特定值复制和粘贴行

2 个答案: