一旦找到指定的关键字，VBA就会删除行

Question

继续这个问题，VBA wildcards or partial matches

根据要求，并为了他人的利益。

用户Flephal提供了本文底部的代码。

代码搜索关键字列表并删除所有不包含这些关键字的列。

问题的最后一部分是现在修改此代码，以便删除包含关键字的行上方的任何行。关键字始终位于同一行。 例如，如果关键字位于第5行，则需要删除第1行到第4行，因此关键字现在位于第1行。

我需要这个，因为我在另一张纸上有其他公式，它依赖于在下面代码修改的工作表的ROW(1:1)中找到的关键字。

    Sub RemoveExtraCols()
    Dim wsSrc As Worksheet: Set wsSrc = ThisWorkbook.Worksheets("Weights")
    Dim wsDest As Worksheet: Set wsDest = ActiveSheet

    Dim KeyWords() As String
    Dim Temp As Range, FoundRange As Range, i As Long

    With wsSrc
        ' SrcRange should be a single contiguous row or column
        Dim SrcRange As Range: Set SrcRange = .Range(.Cells(5, 37), .Cells(17, 37))
    End With

    With wsDest
        Dim SearchRange As Range: Set SearchRange = wsDest.UsedRange
    End With

    KeyWords = Split(Join(Application.Transpose(SrcRange), "#"), "#")

    For i = 0 To UBound(KeyWords)
        If KeyWords(i) <> "" Then
            Set Temp = FindAll(KeyWords(i), SearchRange, LookIn:=xlValues, LookAt:=xlPart)
            If FoundRange Is Nothing Then
                Set FoundRange = Temp
            Else
                If Not Temp Is Nothing Then Set FoundRange = Application.Union(FoundRange, Temp)
            End If
        End If
    Next i

    For i = SearchRange.Columns.Count To 1 Step -1
        Set Temp = Application.Intersect(SearchRange.Columns(i), FoundRange)
        If Temp Is Nothing Then
            SearchRange.Columns(i).EntireColumn.Delete
        End If
    Next i
End Sub

Function FindAll(What, _
    Optional SearchWhat As Variant, _
    Optional LookIn, _
    Optional LookAt, _
    Optional SearchOrder, _
    Optional SearchDirection As XlSearchDirection = xlNext, _
    Optional MatchCase As Boolean = False, _
    Optional MatchByte, _
    Optional SearchFormat) As Range

    'LookIn can be xlValues or xlFormulas, _
     LookAt can be xlWhole or xlPart, _
     SearchOrder can be xlByRows or xlByColumns, _
     SearchDirection can be xlNext, xlPrevious, _
     MatchCase, MatchByte, and SearchFormat can be True or False. _
     Before using SearchFormat = True, specify the appropriate settings for the Application.FindFormat _
     object; e.g. Application.FindFormat.NumberFormat = "General;-General;""-"""

    Dim SrcRange As Range
    If IsMissing(SearchWhat) Then
        Set SrcRange = ActiveSheet.UsedRange
    ElseIf TypeOf SearchWhat Is Range Then
        Set SrcRange = IIf(SearchWhat.Cells.Count = 1, SearchWhat.Parent.UsedRange, SearchWhat)
    ElseIf TypeOf SearchWhat Is Worksheet Then
        Set SrcRange = SearchWhat.UsedRange
    Else: SrcRange = ActiveSheet.UsedRange
    End If
    If SrcRange Is Nothing Then Exit Function

    'get the first matching cell in the range first
    With SrcRange.Areas(SrcRange.Areas.Count)
        Dim FirstCell As Range: Set FirstCell = .Cells(.Cells.Count)
    End With

    Dim CurrRange As Range: Set CurrRange = SrcRange.Find(What:=What, After:=FirstCell, LookIn:=LookIn, LookAt:=LookAt, _
        SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)

    If Not CurrRange Is Nothing Then
        Set FindAll = CurrRange
        Do
            Set CurrRange = SrcRange.Find(What:=What, After:=CurrRange, LookIn:=LookIn, LookAt:=LookAt, _
            SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)
            If CurrRange Is Nothing Then Exit Do
            If Application.Intersect(FindAll, CurrRange) Is Nothing Then
                Set FindAll = Application.Union(FindAll, CurrRange)
            Else: Exit Do
            End If
        Loop
    End If
End Function

Answer 1

我认为应该这样做

Sub RemoveExtraCols()
    Dim wsSrc As Worksheet: Set wsSrc = ThisWorkbook.Worksheets("Weights")
    Dim wsDest As Worksheet: Set wsDest = ActiveSheet
    Dim nRow As Long
    Dim KeyWords() As String
    Dim Temp As Range, FoundRange As Range, i As Long

    With wsSrc
        ' SrcRange should be a single contiguous row or column
        Dim SrcRange As Range: Set SrcRange = .Range(.Cells(5, 37), .Cells(17, 37))
    End With

    With wsDest
        Dim SearchRange As Range: Set SearchRange = wsDest.UsedRange
    End With

    KeyWords = Split(Join(Application.Transpose(SrcRange), "#"), "#")

    For i = 0 To UBound(KeyWords)
        If KeyWords(i) <> "" Then
            Set Temp = FindAll(KeyWords(i), SearchRange, LookIn:=xlValues, LookAt:=xlPart)
            If FoundRange Is Nothing Then
                Set FoundRange = Temp
            Else
                If Not Temp Is Nothing Then Set FoundRange = Application.Union(FoundRange, Temp)
            End If
        End If
    Next i

    If Not FoundRange Is Nothing Then
        nRow = FoundRange(1).Row
        Range("A1").Resize(nRow - 1).EntireRow.Delete shift:=xlUp
    End If

    For i = SearchRange.Columns.Count To 1 Step -1
        Set Temp = Application.Intersect(SearchRange.Columns(i), FoundRange)
        If Temp Is Nothing Then
            SearchRange.Columns(i).EntireColumn.Delete
        End If
    Next i
End Sub