Копирование и вставка строк на основе определенного значения в диапазоне

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

Вы также можете использовать 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

Answer 2

Изменение:

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

---

Примечание : более быстрый способ - не Копировать >> Вставить столько раз, но использовать объект CopyRng, который сохранит все объединенные r, где критерий удовлетворен, а затем в конце просто скопируйте >> вставьте один раз (также не нужно заранее 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)