想保留包含如下字样的行，其它行删除，怎么用VBA实现。

大塔
长新
立富
方正
科
因为经常看这种统计表，只需要包含上面这些文字的行，其它行删除，筛选能实现
但每次都筛选比较麻烦，如果能VBA实现会方便很多。

Sub panda()'方法1

Dim arr, brr, i&, Arow&, str

arr = Range("d2:d" & Cells(Rows.Count, 2).End(3).Row)

Arow = UBound(arr, 1)

ReDim brr(1 To Arow)

    For i = 1 To UBound(arr)

        For Each str In Array("大塔", "长新", "立富", "方正", "科")

            If arr(i, 1) Like "*" & str & "*" Then brr(i) = arr(i, 1): Exit For Else brr(i) = ""

        Next

    Next

[d2].Resize(Arow, 1) = Application.Transpose(brr)

Columns(4).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

Sub test()'方法2

  Dim r%, i%

  Dim arr

  Dim reg As New RegExp

  Dim rng As Range

  With reg

    .Global = True

    .Pattern = "大塔|长新|立富|方正|科"

  End With

  With Worksheets("sheet1")

    r = .Cells(.Rows.Count, 4).End(xlUp).Row

    arr = .Range("d1:d" & r)

    Set rng = .Rows(r + 1)

    For i = 2 To UBound(arr)

      If Not reg.test(arr(i, 1)) Then

        Set rng = Union(rng, .Rows(i))

      End If

    Next

    rng.Delete

  End With

End Sub

Sub zz()'方法三
    arr = Sheet1.Range("A1").CurrentRegion: m = 1
    For i = 2 To UBound(arr)
        If InStr(arr(i, 4), "大塔") > 0 Or InStr(arr(i, 4), "长新") > 0 Or InStr(arr(i, 4), "立富") > 0 _
            Or InStr(arr(i, 4), "方正") > 0 Or InStr(arr(i, 4), "科") > 0 Then
            m = m + 1
            For j = 1 To UBound(arr, 2)
                arr(m, j) = arr(i, j)
            Next
        End If
    Next
    Sheet2.Range("A1").Resize(m, UBound(arr, 2)) = arr
End Sub