VBA - 单元格搜索需要查找多个文本

Question

我设法让我的代码在Excel中查看特定的Cell（D1）以获取我想要搜索的值，但是我需要能够在这种情况下找到多个文本“Internet”和“非互联网”。

但我无法弄清楚如何让代码查找多个单词。

如果有人能指出我正确的方向，我们将不胜感激。

Set sh1 = Sheets("Groupings") 'data sheet
Set sh2 = Sheets("Sheet1") 'paste sheet

myVar = sh1.Range("D1")

Lastrow = sh1.Range("B" & Rows.Count).End(xlUp).Row

For i = 2 To Lastrow '2 being the first row to test
If Len(sh1.Range("A" & i)) > 0 Then
Set myFind = Nothing

If WorksheetFunction.CountA(sh1.Range("A" & i, "A" & Lastrow)) > 1 Then
    If Len(sh1.Range("A" & i + 1)) = 0 Then
        nextrow = sh1.Range("A" & i).End(xlDown).Row - 1
    Else
        nextrow = nextrow + 1
    End If
        Set myFind = sh1.Range("B" & i, "B" & nextrow).Find(What:=myVar, LookIn:=xlFormulas, LookAt:=xlWhole)

Else
    nextrow = Lastrow
    Set myFind = sh1.Range("B" & i, "B" & nextrow).Find(What:=myVar, LookIn:=xlFormulas, LookAt:=xlWhole)


End If

If myFind Is Nothing Then
    sh1.Range("A" & i, "B" & nextrow).Copy
    sh2.Range("A" & sh2.Range("B" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
End If
End If
Next
End Sub

此图像显示当前在分组表上的内容，在列D1中显示互联网一词。

我的第二张图片显示了Sheet1这是复制列A-B的地方，只要单元格D1中的单词没有出现，所以目前我在Sheet1中的信息没有单词“internet”。

我希望将其扩展为包括“互联网”和“非互联网”

Answer 1

在上面的代码中添加：

myVar2 = sh1.Range("D2") 'below myVar1

Set myFind2 = sh1.Range("B" & i, "B" & nextrow).Find(What:=myVar2, LookIn:=xlFormulas, LookAt:=xlWhole) 'below the two myFind

将If myFind Is Nothing Then替换为If (myFind Is Nothing And myFind2 Is Nothing) Then

Answer 2

下面是一个处理任何关键字编号的解决方案

Option Explicit

Sub MultipleKeywordSearch()

Dim dataSht As Worksheet, pasteSht As Worksheet, tempSht As Worksheet
Dim dataRng As Range, keywordsRng As Range
Dim fnd As Range, databaseRng As Range, dataCopyRng As Range
Dim fullNoNames As Variant

Set dataSht = ThisWorkbook.Sheets("Groupings") ' <== set the name of your "data" sheet
Set pasteSht = ThisWorkbook.Sheets("Groupings-res") '<== set the name of the sheet where to paste filtered data

With dataSht
    Set keywordsRng = .Range("D1:D" & .Cells(.Rows.Count, 4).End(xlUp).Row) '<== set where you put "keywords"
    Set dataRng = .Range("A1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row)     '<== set "data" range
End With


Call DuplicateAndFillDataBaseInTempSheet(dataRng, databaseRng, dataCopyRng, tempSht) 'set up a "temp" sheet to copy "data" twice into, one of them is "filled" to reach a "database" structure for further processing

fullNoNames = GetVariantFromRange(GetKeywordsRange(GetVariantFromRange(keywordsRng), databaseRng, 2, -1)) ' gather "FullNames" that match keywords

GetKeywordsRange(fullNoNames, databaseRng, 1, 0).EntireRow.Delete 'delete "temp" sheet rows that match "fullnames"

If databaseRng.Rows.Count > 1 Then 'if any records survive...
    databaseRng.Copy               ' then copy ...
    pasteSht.Cells(pasteSht.Rows.Count, 2).End(xlUp).Offset(1,-1).PasteSpecial xlPasteValues '...and paste them into your "paste" sheet
End If

'delete "temp" sheet
Application.DisplayAlerts = False
tempSht.Delete
Application.DisplayAlerts = True

End Sub




Sub DuplicateAndFillDataBaseInTempSheet(valuesRng As Range, databaseRng As Range, dataCopyRng As Range, tempSht As Worksheet)
Dim valuesAddress As String

valuesAddress = valuesRng.Address
Set tempSht = SetSheet("temp")
With tempSht
    Set databaseRng = .Range(valuesAddress)
    valuesRng.Copy databaseRng
    Call FillIn(databaseRng)

    Set dataCopyRng = databaseRng.Offset(, databaseRng.Columns.Count + 4)
    valuesRng.Copy dataCopyRng
End With

End Sub


Function GetVariantFromRange(rng As Range) As Variant
Dim var As Variant
Dim cell As Range
Dim iCell As Long

ReDim var(1 To rng.Cells.Count)
For Each cell In rng
    iCell = iCell + 1
    var(iCell) = cell.Value
Next cell
GetVariantFromRange = var

End Function


Function GetKeywordsRange(keywordsArray As Variant, databaseRng As Range, searchCol As Long, resOffsetCol As Long) As Range
Dim fnd As Range, cell As Range, databaseLocalRange As Range, dummyFnd As Range
Dim iVar As Long

Set dummyFnd = databaseRng(1, 1)
Set fnd = dummyFnd ' to prevent "Union" method in "GetValueRange()" to fail the first time
Set databaseLocalRange = databaseRng.Resize(databaseRng.Rows.Count - 1).Offset(1)
For iVar = LBound(keywordsArray) To UBound(keywordsArray)
    Set fnd = GetValueRange(databaseLocalRange.Columns(searchCol), keywordsArray(iVar), fnd, resOffsetCol)
Next iVar

dummyFnd.EntireRow.Hidden = True 'hide first row (header row) to prevent it to be selected by subsequent statement (that filters only visible cells)
Set GetKeywordsRange = fnd.SpecialCells(xlCellTypeVisible)
dummyFnd.EntireRow.Hidden = False 'show first row again

End Function


Function GetValueRange(rngToSearchIn As Range, itemToFind As Variant, rngToUnion As Range, colOffset As Long) As Range
Dim cell As Range
Dim firstAddress As String

With rngToSearchIn
    Set cell = .Find(What:=itemToFind, After:=rngToSearchIn.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not cell Is Nothing Then
        firstAddress = cell.Address
        Do
            Set rngToUnion = Union(rngToUnion, cell.Offset(, colOffset))
            Set cell = .FindNext(cell)
        Loop While cell.Address <> firstAddress
    End If
        Set GetValueRange = rngToUnion
End With

End Function


Function SetSheet(shtName As String) As Worksheet

On Error Resume Next
ThisWorkbook.Sheets(shtName).Activate
If Err <> 0 Then
    On Error GoTo 0
    ThisWorkbook.Worksheets.Add
    ActiveSheet.name = shtName
Else
    ActiveSheet.Cells.Clear
End If
Set SetSheet = ActiveSheet

End Function


Sub FillIn(rngToFill As Range)

On Error Resume Next 'Need this because if there aren’t any blank cells, the code will error
rngToFill.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
rngToFill.Value = rngToFill.Value

End Sub