vba删除不包含范围中定义的设置值的行

我有一张25k行的数据表。我需要在整个工作表中搜索我在选项卡2的命名范围中定义的特定单词，称为“关键字searh”。该范围包含我需要在主数据中查找的单词列表。我想删除所有不包含这些关键字的行（并向上移动所有保留行），只保留引用关键字的行（包括标题行）。关键字可以作为文本写入任何单元格中，该单元格也将包含其他文本，因此搜索函数需要查看每个字符串，而不是特定于大小写

我认为下面链接上的代码很接近，但这不是指范围。此外，我只需要搜索一个名为“公平”的工作表。

---

我是VBA的新手，因此非常感谢您的帮助。

以下是一种非VBA的方法。选择要更改的范围，转到条件格式>高亮显示单元格规则>更多规则>使用公式确定要格式化的单元格。选择一种颜色以高亮显示单元格，并键入包含范围的公式：

=COUNTIF（公平！$A$1:$A$10，A1）

哪里公平$A$1:$A$10是您的关键字范围，A1是您试图更改的范围的第一个单元格

---

然后，您可以按color=no-fill筛选列表，只选择和删除可见单元格（Ctrl+G>Special>visible cells only）。

以下过程将搜索整个工作表中的值数组，然后删除工作表中未找到这些值的所有行

    Sub Example1()

    Dim varList As Variant
    Dim lngarrCounter As Long
    Dim rngFound As Range, rngToDelete As Range
    Dim strFirstAddress As String

    Application.ScreenUpdating = False

    varList = VBA.Array("Here", "There", "Everywhere") 'You will need to change this to reflect your Named range

    For lngarrCounter = LBound(varList) To UBound(varList)

        With Sheets("Fair").UsedRange 'Change the name to the sheet you want to filter
            Set rngFound = .Find( _
                                What:=varList(lngarrCounter), _
                                Lookat:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=True)

            If Not rngFound Is Nothing Then
                strFirstAddress = rngFound.Address

                If rngToDelete Is Nothing Then
                    Set rngToDelete = rngFound
                Else
                    If Application.Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
                        Set rngToDelete = Application.Union(rngToDelete, rngFound)
                    End If
                End If

                Set rngFound = .FindNext(After:=rngFound)

                Do Until rngFound.Address = strFirstAddress
                    If Application.Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
                        Set rngToDelete = Application.Union(rngToDelete, rngFound)
                    End If
                    Set rngFound = .FindNext(After:=rngFound)
                Loop
            End If
        End With
    Next lngarrCounter

    If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete

    Application.ScreenUpdating = True

End Sub

这段代码是从另一个网站改编的，出于某种原因，我无法将链接粘贴到这里

首先，您需要创建一个函数来查找最后一行：

    Public Function GetLastRow(ByVal rngToCheck As Range) As Long

    Dim rngLast As Range

    Set rngLast = rngToCheck.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)

    If rngLast Is Nothing Then
        GetLastRow = rngToCheck.Row
    Else
        GetLastRow = rngLast.Row
    End If

End Function

现在，使用下面的代码查找数组上的值。它将搜索整个工作表并删除未找到该值的任何行

    Sub Example1()

    Dim varList As Variant
    Dim lngarrCounter As Long
    Dim rngFound As Range, rngToDelete As Range
    Dim strFirstAddress As String

    Application.ScreenUpdating = False

    varList = VBA.Array("Here", "There", "Everywhere") 'You will need to change this to reflect your Named range

    For lngarrCounter = LBound(varList) To UBound(varList)

        With Sheets("Fair").UsedRange 'Change the name to the sheet you want to filter
            Set rngFound = .Find( _
                                What:=varList(lngarrCounter), _
                                Lookat:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=True)

            If Not rngFound Is Nothing Then
                strFirstAddress = rngFound.Address

                If rngToDelete Is Nothing Then
                    Set rngToDelete = rngFound
                Else
                    If Application.Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
                        Set rngToDelete = Application.Union(rngToDelete, rngFound)
                    End If
                End If

                Set rngFound = .FindNext(After:=rngFound)

                Do Until rngFound.Address = strFirstAddress
                    If Application.Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
                        Set rngToDelete = Application.Union(rngToDelete, rngFound)
                    End If
                    Set rngFound = .FindNext(After:=rngFound)
                Loop
            End If
        End With
    Next lngarrCounter

    If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete

    Application.ScreenUpdating = True

End Sub

---

如果您需要进一步帮助，请告诉我。

如果列表中的某个单词与正在搜索的工作表中的某个单词部分匹配，该怎么办？不应该删除该行吗？您的搜索列表包含“范围”，数据表上的一个单元格有“橙色”。。