Comparing strings using InStr() - vba help required

[VeryForgetful]

Hi All,

I am using the code below to search for a keyword in a string against a list of keywords located in another tab, if the word exists then the row is copied over to another sheet.

The code works, however it has to be run twice to complete successfully. I am using a nested For Each Loop, the outer one is to loop through each keyword in the list and the inner loop for each cell where the string needs to be checked. I have attached a copy of the workbook if anyone can assist please?

https://1drv.ms/x/s!AilrZgAqVaaqmTEk0Ku7G8iY4uSv

Sub CopyRows()


    Dim SrcSheet As Worksheet
    Dim DstSheet As Worksheet
    Dim KeywordSheet As Worksheet
    Dim LrSrc As Long
    Dim c As Range
    Dim x As Range
    Dim LookupRange As Range
    Dim LrLookup As Long


    Set SrcSheet = Sheets("Raw Data")
    Set DstSheet = Sheets("Filtered Results")
    Set KeywordSheet = Sheets("Keyword Search")


    SrcSheet.Columns.AutoFit


    LrSrc = SrcSheet.Range("A" & Rows.Count).End(xlUp).Row
    LrLookup = KeywordSheet.Range("A" & Rows.Count).End(xlUp).Row


    Set LookupRange = KeywordSheet.Range("A2:A" & LrLookup)


    For Each x In LookupRange
        For Each c In SrcSheet.Range("A2:A" & LrSrc)
            Debug.Print "Checking for keyword: " & x.Value; " in string " & c.Value
            Application.StatusBar = "Checking for keyword: " & x.Value
            If InStr(UCase(c.Value), UCase(x.Value)) > 0 Then 'convert both values to uppercase to compare
                c.EntireRow.Copy DstSheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
                c.EntireRow.Delete Shift:=xlUp
            End If
        Next c
    Next x


    DstSheet.Columns.AutoFit
    Application.StatusBar = False


End Sub

 

[Fluff]

How about

Sub CopyRows()

    Dim SrcSheet As Worksheet
    Dim DstSheet As Worksheet
    Dim KeywordSheet As Worksheet
    Dim LrSrc As Long
    Dim c As Range
    Dim x As Range
    Dim LookupRange As Range
    Dim LrLookup As Long
    Dim Rng As Range
    
    Set SrcSheet = Sheets("Raw Data")
    Set DstSheet = Sheets("Filtered Results")
    Set KeywordSheet = Sheets("Keyword Search")

    SrcSheet.Columns.AutoFit

    LrSrc = SrcSheet.Range("A" & Rows.Count).End(xlUp).Row
    LrLookup = KeywordSheet.Range("A" & Rows.Count).End(xlUp).Row

    Set LookupRange = KeywordSheet.Range("A2:A" & LrLookup)

    For Each x In LookupRange
        For Each c In SrcSheet.Range("A2:A" & LrSrc)
            Debug.Print "Checking for keyword: " & x.Value; " in string " & c.Value
            Application.StatusBar = "Checking for keyword: " & x.Value
            If InStr(1, c.Value, x.Value, vbTextCompare) > 0 Then 'convert both values to uppercase to compare
               If Rng Is Nothing Then
                  Set Rng = c
               Else
                  Set Rng = Union(Rng, c)
               End If
            End If
        Next c
    Next x
    If Not Rng Is Nothing Then
      Rng.EntireRow.Copy DstSheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
      Rng.EntireRow.Delete Shift:=xlUp
    End If


    DstSheet.Columns.AutoFit
    Application.StatusBar = False

End Sub

 

[VeryForgetful]

This works great thanks.

Any idea what was wrong with my original code? I can see you have used an additional range variable and also the instr line has changed.

Cheers

 

[Fluff]

When deleting (or inserting) rows(columns) in the way that you were its best to work backwards (bottomup for rows right to left for columns).
With your code if A2 was deleted then A3 becomes A2. You then hit next c which takes you to A3, which was originally A4 & so the original A3 never gets checked.

So rather than completely re doing your code I created a new variable Rng which stores all the cells that need deleting & then that is used to delete all rows in one hit at the end.
With regards the InStr. There wasn't anything particularly wrong with what you did, but using vbtextcompare makes the comparison case insensitive, therefore no need for the UCase