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

 

[Cubist]

You're welcome. Glad to help.

 

[topi1]

@Cubist Help please.

Of the following six, 2 had the same string from U. i.e. Delim4.

Instead of both being displayed in the final results one got entirely deleted.

BEFORE:

Delim2. Minerva is showing Abba.

Metro shows Dunn next month. Delim3. Closed today.

Strand showsJames Bond. Delim4.

Eros shows Superman nextweek. Delim4.

Before Metro Roxi shows Cars.

After Eros Strand shows Abba. AFTER: Minerva is showing Abba. Metro shows Dunn next month. Closed today. Eros shows Superman nextweek.

 

[topi1]

If you are going to modify the code, can you please change the location of U column from sheet2 to sheet1? TY. Much obliged.

 

[Cubist]

This should work for multiple instances. Changed U to sheet 2.

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("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 = ThisWorkbook.Sheets("Sheet2")Range("U1:U" & ws.Cells(ws.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 Cells(i, "R").Value = "" Then
            Rows(i).Delete
        End If
    Next i
End Sub

 

[Cubist]

Some minor changes to make the sheets more dynamic.

Sub CheckAndClear()
    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("Sheet3") ' Change Sheet3 to your sheet name
    Set ws2 = ThisWorkbook.Sheets("Sheet2") ' 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
            dataQ(i, 1) = ""
        End If
    Next i

    ws.Range("R" & foundRow).Resize(UBound(foundWords), 1).Value = foundWords
    
    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]

@Cubist Perfect. Flawless. Thank you for so much of your time.

 

[topi1]

TY. Will try. I had modified the one earlier as follows to look at column U in sheet1 instead of sheet2.


Set ws = ThisWorkbook.Sheets("Sheet1")
dataU = ws.Range("U1:U" & ws.Cells(ws.Rows.Count, "U").End(xlUp).Row).value

Set ws = ThisWorkbook.Sheets("Sheet2") ' Switch back to Sheet2

 

[topi1]

Some minor changes to make the sheets more dynamic.

Sub CheckAndClear()
    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("Sheet3") ' Change Sheet3 to your sheet name
    Set ws2 = ThisWorkbook.Sheets("Sheet2") ' 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
            dataQ(i, 1) = ""
        End If
    Next i

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

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

 

[topi1]

@Cubist I can post a separate thread but since you have been so helpful, I will ask for your help with a difficult code.

Trying to copy and paste Based on first occurrence in the cells.

Part I
When the cells below TITLE2 starts with "After" or "Below", want the rows to be copied and pasted below the row where column O cell is identical.

Part II
When the cells below TITLE2 starts with "Before" or "Above", want the rows to be copied and pasted above the row where column O cell is identical.

I can use formulas, but I would like to use VBA if possible.

Here is the example

Before:

Book1
	O	P	Q	R
1				Theater:
2				Movie:
3
4
5				TITLE1
6
7	Eros	Eros:	4	Eros: Dunn
8	Regal	Regal:	4	Regal: Superman
9	Metro	Metro:	4	Metro: Batman
10	Minerva	Minerva:	4	Minerva: Starwars
11
12
13				TITLE2
14				Eros shows Superman nextweek. Delim4.
15				Metro shows Dunn next month. Delim3. Closed today.
16				Delim2. Minerva is showing Abba.
17	Metro	Place		Before Metro Roxi shows Cars.
18	Eros	Place		After Eros Strand shows Abba.
19	Eros	Place		After Eros Mandir shows Sholay
20	Metro	Place		Before Metro Opera House shows Shor
21	Eros	Place		After Eros Mandir shows Sholay
22	Metro	Place		Before Metro Opera House shows Shor
Sheet3

After:

Book1
	O	P	Q	R
1				Theater:
2				Movie:
3
4
5				TITLE1
6
7	Eros	Eros:	4	Eros: Dunn
8	Eros	Place	4	After Eros Strand shows Abba.
9	Eros	Place	4	After Eros Mandir shows Sholay
10	Regal	Regal:	4	Regal: Superman
11	Metro	Place	4	Before Metro Roxi shows Cars.
12	Metro	Place	4	Before Metro Opera House shows Shor
13	Metro	Metro:	4	Metro: Batman
14	Minerva	Minerva:	4	Minerva: Starwars
15
16
17				TITLE2
18				Eros shows Superman nextweek. Delim4.
19				Metro shows Dunn next month. Delim3. Closed today.
20				Delim2. Minerva is showing Abba.
21	Metro	Place	4	Before Metro Roxi shows Cars.
22	Eros	Place	4	After Eros Strand shows Abba.
23	Eros	Place	4	After Eros Mandir shows Sholay
24	Metro	Place	4	Before Metro Opera House shows Shor
Sheet3

 

[Cubist]

I recommend starting a new thread anyways. You’ll have more people viewing your thread better chance of an optimal solution. You can tag me or dm me the link to the new thread. Thanks.