Question

下面的代码会在第37行第5到第17行的另一个名为＆＃34; Weights＆＃34;的其他工作表中查看关键字列表。

对于不包含这些关键字的列，请将其删除。

我的问题是它正在寻找完全匹配，所以我需要放置一些通配符或调整以下内容以包含部分匹配。

例如，如果某个关键字是＆＃34;打开＆＃34;，则该列包含＆＃34;打开＆amp;关闭＆＃34;将被删除，这不是我想要的。

如何最好地解决这个问题？

Sub DeleteUneededColumn()

Dim rng As Range, rngcol As Range
Dim findstring As Variant

With Sheets("Weights")
    findstring = .Range(.Cells(5, 37), .Cells(17, 37))
End With
For Each rngcol In Range("A:CZ").Columns
    myVal = 0
    For i = LBound(findstring) To UBound(findstring)
        myVal = myVal + Evaluate("=IF(COUNTIF(" & rngcol.Address & ",""" & findstring(i, 1) & """)>0,1,0)")
    Next
    If myVal = 0 Then
        If Not rng Is Nothing Then
            Set rng = Union(rng, rngcol)
        Else
            Set rng = rngcol
        End If
    End If
Next
If Not rng Is Nothing Then rng.Delete

End Sub

Answer 1

以下代码应该适合您......

sub获取Sheet中的关键字（“Weights”）并将它们添加到数组中，然后循环遍历数组，查找目标范围中的每个术语。它们将循环遍历目标范围并删除任何与所有找到的搜索范围的并集不相交的列

将wsDest和SearchRange设置为要从中删除列的工作表/范围

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

VBA通配符或部分匹配

1 个答案: