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]

Perfect. Changes sheet3 to Sheet2 and sheet2 to sheet1> And I am in business. Appreciate it.

@Cubist Sorry to bother you but why do I sometimes get the following error? Thank you.

foundWords(foundIndex, 1) = dataR(i, 1)

 

[topi1]

The data is contiguous. No blank rows.

 

[Cubist]

What's the error message?

 

[topi1]

Tge Vba stops and upon debugging, the above line is highlighted yellow.

 

[Cubist]

When it stops, it gives you an error message/code. What is it?

 

[topi1]

Upon debugging, the vba displays the entire code with the following line highlighted yellow.

foundWords(foundIndex, 1) = dataR(i, 1)

 

[Cubist]

Yes, I'm aware that it highlights yellow, but it gives you an error message box. What does it say on the error message box?

 

[topi1]

Here is how it looks. Could not find highlight. The error line in the following is displayed in bold red.

Sub CheckAndClear_OneA()
Dim ws As Worksheet, ws2 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("Sheet2") ' Change Sheet3 to your sheet name
Set ws2 = ThisWorkbook.Sheets("Sheet1") ' Set ws2 to refer to Sheet2

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 = ws2.Range("U1:U" & ws2.Cells(ws2.Rows.Count, "U").End(xlUp).Row).value

foundRow = 1
foundIndex = 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(foundIndex, 1) = dataR(i, 1)
For k = LBound(dataU) To UBound(dataU)
foundWords(foundIndex, 1) = Trim(Replace(foundWords(foundIndex, 1), dataU(k, 1), "", , , vbTextCompare))
Next k
foundIndex = foundIndex + 1
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 ws.Cells(i, "R").value = "" Then
ws.Rows(i).Delete
End If
Next i
End Sub

 

[topi1]

I was not aware. Let me check.

 

[topi1]

Run time error '9':

Subscript out of range.