VBA - cell search need multiple text looked up

Question

I have managed to get my code to look at a specific Cell (D1) in Excel to pick up the value I want to search for, however I need to be able to find multiple text in this case "Internet" and "Non-internet".

But I can't work out how to get the code to look up more than one word.

If anyone could point me in the right direction it would be greatly appreciated.

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

This image shows what currently is on the groupings sheet and in column D1 the word internet is shown.

My second image shows Sheet1 this is where columns A-B are copied as long as the word in Cell D1 doesn't appear, so currently my information in Sheet1 does not have the word "internet".

I am looking to expand this to include "internet" and "non-internet"

Answer 1

here follows a solution to handle whatever keywords number

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

Answer 2

In your above code add:

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

And replace If myFind Is Nothing Then with If (myFind Is Nothing And myFind2 Is Nothing) Then