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]

@Cubist The above code did not work. One of the earlier versions as follows worked. I am not capable of deciphering the difference between the recent ones and the following. TY.

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("Sheet2") ' 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

 

[Cubist]

This code doesn't have U on Sheet1 and it doesn't sort based on the Delim list. The prior code addresses both and works on my tests. I'm not sure what else.

 

[topi1]

Thank you. I’ll use the one which is working more consistently in my work book. Thank you.

 

[topi1]

@Cubist So far so good. The following code seems to be working consistently. Thank you. Wanted to give you follow up since you helped me a lot.

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("Sheet2") ' 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

 

[topi1]

@Cubist I am sorry to keep bothering. I am at a total loss why the code is inconsistent. It stopped working. Even in the new workbook. Ends up deleting rows it should not.

 

[topi1]

Identical thing. Working again. Sorry to have bothered.