Match and delete

[topi1]

Need help with VBA. TY.

In the following example, I want the vba to loop through all column R cells where the column Q value is 9. Match the strings in those cells and see if they contain any of the strings in the column U. case insensitive match is fine. If the cell in the column R with column Q=9 does not contain any of the column U strings, delete it. Thank you. If the code works, last two cells should be deleted.

Book1
	Q	R	S	T	U
1		Theater:			delim1.
2		Movie:			delim2.
3					delim3.
4					delim4.
5		TITLE1			delim5.
6					delim6.
7	4	Eros: Dunn			delim7.
8	4	Strand shows Abba.			delim8.
9	4	Regal: Superman			delim9.
10	4	Roxi shows Cars.			delim10.
11	4	Metro: Batman
12	4	Minerva: Starwars
13
14
15
16	5	Eros shows Superman nextweek.
17	5	Metro shows Dunn next month.
18	5
19		TITLE2
20	9	Eros shows Superman nextweek. Delim4.
21	9	Metro shows Dunn next month. Delim3. Closed today.
22	9	Delim2. Minerva is showing Abba.
23	9	Before Metro Roxi shows Cars.
24	9	After Eros Strand shows Abba.
Sheet2

 

[topi1]

In the most complex examples, it can have 15 or so rows with 1 to 3 blank rows in between. All random.

 

[topi1]

I mean it is fine to remove entire rows for all column R cells which are blank.

 

[topi1]

May be better to first create contiguous data in R??

 

[Cubist]

Would you ever encounter something like this where the 9s are not together?

Book1
	Q	R	S	T	U
1		Theater:			delim1.
2		Movie:			delim2.
3					delim3.
4					delim4.
5		TITLE1			delim5.
6					delim6.
7	4	Eros: Dunn			delim7.
8	4	Strand shows Abba.			delim8.
9	4	Regal: Superman			delim9.
10	4	Roxi shows Cars.			delim10.
11	4	Metro: Batman
12	4	Minerva: Starwars
13
14	9	Eros shows Superman nextweek. Delim4.
15	9	Metro shows Dunn next month. Delim3. Closed today.
16
17
18	5	Eros shows Superman nextweek.
19	5	Metro shows Dunn next month.
20
21		TITLE2
22	9	Delim2. Minerva is showing Abba.
Sheet1

 

[topi1]

No. 9 will be always belw the row which has TITLE2 in the column R. Never above. It is possible that delim1, delim2 etc may have more than one occurrence in the column R below TITLE2. In that case the order will be first come first.

 

[Cubist]

Try this on a COPY. Since you're deleting blank rows in R. It'll also delete your delimiters in U.

Sub CheckAndClear()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long, j As Long
    Dim dataQ As Variant, dataR As Variant, dataU As Variant
    Dim wordFound As Boolean
    Dim foundWords() As String
    Dim foundIndex As Long
   
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change Sheet1 to your sheet name

    lastRow = ws.Cells(ws.Rows.Count, "Q").End(xlUp).Row

    dataQ = ws.Range("Q1:Q" & lastRow).Value
    dataR = ws.Range("R1:R" & lastRow).Value
    dataU = ws.Range("U1:U" & ws.Cells(ws.Rows.Count, "U").End(xlUp).Row).Value
    foundRow = 1
    ReDim foundWords(1 To UBound(dataR, 1), 1 To 1)
    For i = 1 To UBound(dataQ, 1)
        If dataQ(i, 1) = 9 Then
            If foundRow = 1 Then foundRow = i ' Store the first row 9
            For j = 1 To UBound(dataU, 1)
                If InStr(1, dataR(i, 1), dataU(j, 1), vbTextCompare) > 0 Then
                    foundWords(j, 1) = dataR(i, 1)
                    Exit For
                End If
            Next j
        Cells(i, "R").ClearContents
        End If
    Next i

 ws.Range("R" & foundRow).Resize(UBound(foundWords), 1).Value = foundWords
 
 For i = lastRow To 1 Step -1
       If Cells(i, "R").Value = "" Then
        Rows(i).Delete
    End If
Next i
End Sub

 

[topi1]

Thank you.I removed all blanks and tried it. Got the following error:

    ReDim foundWords(1 To UBound(dataR, 1), 1 To 1)

 

[topi1]

@Cubist Thank you for your time and help. Tried again it worked. In first part.
The second part I was hoping for did not change. May be I was not clear. I am sorry. No rush but certainly will like your help with it. Thank you again.

 

[Cubist]

I forgot you wanted to remove the delims.
Try this.

Sub CheckAndClear()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long, j As Long, k As Long
    Dim dataQ As Variant, dataR As Variant, dataU As Variant
    Dim foundRow As Long
    Dim foundWords() As String

    Set ws = ThisWorkbook.Sheets("Sheet3") ' Change Sheet1 to your sheet name

    lastRow = ws.Cells(ws.Rows.Count, "Q").End(xlUp).Row

    dataQ = ws.Range("Q1:Q" & lastRow).Value
    dataR = ws.Range("R1:R" & lastRow).Value
    dataU = ws.Range("U1:U" & ws.Cells(ws.Rows.Count, "U").End(xlUp).Row).Value
    foundRow = 1
    ReDim foundWords(1 To UBound(dataR, 1), 1 To 1)

    For i = 1 To UBound(dataQ, 1)
        If dataQ(i, 1) = 9 Then
            If foundRow = 1 Then foundRow = i ' Store the first row 9
            For j = 1 To UBound(dataU, 1)
                If InStr(1, dataR(i, 1), dataU(j, 1), vbTextCompare) > 0 Then
                    foundWords(j, 1) = dataR(i, 1)
            For k = LBound(dataU) To UBound(dataU)
                foundWords(j, 1) = Trim(Replace(foundWords(j, 1), dataU(k, 1), "", , , vbTextCompare))
            Next k
                    Exit For
                End If
            Next j
            Cells(i, "R").ClearContents
        End If
    Next i

    ' Output modified strings to column R starting from foundRow
    ws.Range("R" & foundRow).Resize(UBound(foundWords), 1).Value = foundWords

    ' Delete rows where no modifications were made
    For i = lastRow To 1 Step -1
        If Cells(i, "R").Value = "" Then
            Rows(i).Delete
        End If
    Next i
End Sub

Outcome:

Book1
	Q	R
1		Theater:
2		Movie:
3		TITLE1
4	4	Eros: Dunn
5	4	Strand shows Abba.
6	4	Regal: Superman
7	4	Roxi shows Cars.
8	4	Metro: Batman
9	4	Minerva: Starwars
10	5	Eros shows Superman nextweek.
11	5	Metro shows Dunn next month.
12		TITLE2
13	9	Minerva is showing Abba.
14	9	Metro shows Dunn next month. Closed today.
15	9	Eros shows Superman nextweek.
Sheet3

 

[topi1]

@Cubist Thats crazy good. Thank you so much! Appreciate it.