Копирование строк при нахождении нужного слова

[ma7ter]

Добрый день уважаемые участники форума.
Столкнулся с проблемой - с которой вот уже несколько дней не могу справиться. Надежда как всегда на вас...


Задача - скопировать все строки в таблице эксель, которые содержат в каком либо из столбцов нужное слово, к примеру "слон":

Возможно поможет:
Я нашел на одном из сайтов следующий код для удаления строк которые содержат слово, но как сделать так, что бы они копировались (к примеру в буфер обмена), либо на другой лист??? Также было бы здорово если бы все строки, которые не содержали нужного слова удалялись.


Заранее большое спасибо, надеюсь на вашу помощь.

PHP код:

Sub УдалениеСтрокПоУсловию()
    Dim ra As Range, delra As Range, ТекстДляПоиска As String
    Application.ScreenUpdating = False    ' отключаем обновление экрана

    ТекстДляПоиска = "Наименование ценности"    ' удаляем строки с таким текстом

    ' перебираем все строки в используемом диапазоне листа
   For Each ra In ActiveSheet.UsedRange.Rows
        ' если в строке найден искомый текст
       If Not ra.Find(ТекстДляПоиска, , xlValues, xlPart) Is Nothing Then
            ' добавляем строку в диапазон для удаления
           If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
        End If
    Next
    ' если подходящие строки найдены - удаляем их
   If Not delra Is Nothing Then delra.EntireRow.Delete
End Sub 


[SAS888]

Предлагаю иной способ решения Вашей задачи:

Sub Main()
    Dim i As Long, j As Long, k As Long, FindStr As String, a(), b(), c, d()
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    On Error Resume Next: Sheets("Итог").Delete: On Error GoTo 0
    a = ActiveSheet.UsedRange.Value
    FindStr = "слон" 'строка для поиска
    ReDim d(1 To UBound(a, 1), 1 To UBound(a, 2)): j = 0
    For i = 1 To UBound(a, 1)
        b = Application.Index(a, i, 0): c = Filter(b, FindStr, True)
        If UBound(c) <> -1 Then
            j = j + 1
            For k = 1 To UBound(a, 2): d(j, k) = a(i, k): Next
        End If
    Next
    If j > 0 Then
        Sheets.Add.Name = "Итог": [A1].Resize(UBound(d, 1), UBound(d, 2)).Value = d
    End If
End Sub

Пример во вложении. Откройте файл и запустите макрос "Main".