Выборочно копировать и вставлять строки с заданными критериями

Question

Я пытаюсь выбрать строки в таблице на основе слова «Да», присутствующего в столбце J.

У меня есть таблица, идущая от столбца A к J, и я хочу выбрать строки, в которых есть «Да» в столбце J, и вставить только эти строки в новый лист.

После выбора мне нужно скопировать эти строки в новый лист или документ Word.

Я пробовал ряд форумов, это для программного обеспечения Windows MS Excel, с использованием макроса VBA.

Я использую следующий VBA, но у меня возникают проблемы:

Sub Macro1()
 Dim rngJ As Range
    Dim cell As Range

    Set rngJ = Range("J1", Range("J65536").End(xlUp))
    Set wsNew = ThisWorkbook.Worksheets.Add

    For Each cell In rngJ
        If cell.Value = "Yes" Then
            cell.EntireRow.Copy

            wsNew.Sheets("Sheet1").Range("J65536").End(xlUp).Offset(1, 0).Select

            ActiveSheet.Paste
        End If
    Next cell

End Sub

Любая помощь будет принята с благодарностью!

Answer 1

Используйте что-то вроде этого

Option Explicit

Public Sub CopyYesRowsToNewWorksheet()
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.ActiveSheet 'better define sheet by name ThisWorkbook.Worksheets("SourceSheet")

    Dim DataRangeJ As Variant 'read "yes" data into array for faster access
    DataRangeJ = wsSource.Range("J1", wsSource.Range("J" & wsSource.Rows.Count).End(xlUp)).Value

    Dim wsNew As Worksheet
    Set wsNew = ThisWorkbook.Worksheets.Add

    Dim NextFreeRow As Long
    NextFreeRow = 1 'start pasting in this row in the new sheet

    If IsArray(DataRangeJ) Then        
        Dim iRow As Long
        For iRow = LBound(DataRangeJ) To UBound(DataRangeJ) 'loop through data array
            If DataRangeJ(iRow, 1) = "yes" Then
                wsNew.Rows(NextFreeRow).Value = wsSource.Rows(iRow).Value 'copy the values of the row
                NextFreeRow = NextFreeRow + 1
            End If
        Next iRow
    ElseIf DataRangeJ = "yes" Then 'if only the first row has data
        wsNew.Rows(NextFreeRow).Value = wsSource.Rows(1).Value
    End If
End Sub

Линия

wsNew.Rows(NextFreeRow).Value = wsSource.Rows(iRow).Value

копирует только значение без форматирования. Если вы также хотите скопировать форматирование, замените его на

wsSource.Rows(iRow).Copy Destination:=wsNew.Rows(NextFreeRow)

Answer 2

Вместо поиска, копирования и вставки для каждой ячейки, почему бы не найти все, затем скопируйте и вставьте один раз так:

Sub Macro1()
Dim rngJ As Range
Dim MySel As Range

Set rngJ = Range("J1", Range("J" & Rows.Count).End(xlUp))
Set wsNew = ThisWorkbook.Worksheets.Add

For Each cell In rngJ
    If cell.Value = "Yes" Then
        If MySel Is Nothing Then
            Set MySel = cell.EntireRow
        Else
            Set MySel = Union(MySel, cell.EntireRow)
        End If
    End If
Next cell

If Not MySel Is Nothing Then MySel.Copy Destination:= wsNew.Range("A1")
End Sub

Лучше избегать использования Select в максимально возможной степени;см. ссылку .