VBAワイルドカードまたは部分一致

Question

以下のコードでは、37行目の5〜17行目のキーワードのリストを「ウェイト」という別のシートに表示しています。

これらのキーワードが含まれていない列の場合は、削除してください。

私の問題は完全一致を探しているので、いくつかのワイルドカードを配置するか、部分一致を含めるために以下を調整する必要があります。

例えば、キーワードが "Open"の場合、 "Open & closed"を含む列は削除されますが、これは私が望むものではありません。

どうすればこの問題を解決できますか？次のコードは、あなたのために働く必要があり

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

...サブシート（「ウェイト」）にキーワードを取り、配列に追加します

、その後、各用語を探している配列をループ宛先範囲内にある。 それは、先の範囲を介してそれらループし、見つかったすべての検索は、あなたが列を削除したい/範囲シートにwsDestと探索範囲を設定

の範囲の組合と交差していない任意の列を削除

から

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