VBA – 小区search需要查找多个文本

我已经设法让我的代码在Excel中查看特定单元格（D1）以获取我想要search的值，但是在这种情况下，我需要能够find多个文本“Internet”和“Non-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这是AB列被复制，只要单元格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

这里有一个解决scheme来处理任何关键字的数字

 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