Match and delete

T

topi1

Board Regular
Joined
Aug 6, 2014
Messages
190
Office Version
  1. 2010
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
QRSTU
1Theater:delim1.
2Movie:delim2.
3delim3.
4delim4.
5TITLE1delim5.
6delim6.
74Eros: Dunndelim7.
84Strand shows Abba.delim8.
94Regal: Supermandelim9.
104Roxi shows Cars.delim10.
114Metro: Batman
124Minerva: Starwars
13
14
15
165Eros shows Superman nextweek.
175Metro shows Dunn next month.
185
19TITLE2
209Eros shows Superman nextweek. Delim4.
219Metro shows Dunn next month. Delim3. Closed today.
229Delim2. Minerva is showing Abba.
239Before Metro Roxi shows Cars.
249After Eros Strand shows Abba.
Sheet2
 
Sort by date Sort by votes

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
@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.
 
Upvote 0
If you are going to modify the code, can you please change the location of U column from sheet2 to sheet1? TY. Much obliged.
 
Upvote 0
This should work for multiple instances. Changed U to sheet 2.
VBA Code: 
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
 
Upvote 0
Some minor changes to make the sheets more dynamic.
VBA Code: 
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
 
Last edited:
Upvote 0
Solution
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
 
Upvote 0
Cubist said:
Some minor changes to make the sheets more dynamic.
VBA Code: 
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
Click to expand...
Perfect. Changes sheet3 to Sheet2 and sheet2 to sheet1> And I am in business. Appreciate it.
 
Upvote 0
@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
OPQR
1Theater:
2Movie:
3
4
5TITLE1
6
7ErosEros:4Eros: Dunn
8RegalRegal:4Regal: Superman
9MetroMetro:4Metro: Batman
10MinervaMinerva:4Minerva: Starwars
11
12
13TITLE2
14Eros shows Superman nextweek. Delim4.
15Metro shows Dunn next month. Delim3. Closed today.
16Delim2. Minerva is showing Abba.
17MetroPlaceBefore Metro Roxi shows Cars.
18ErosPlaceAfter Eros Strand shows Abba.
19ErosPlaceAfter Eros Mandir shows Sholay
20MetroPlaceBefore Metro Opera House shows Shor
21ErosPlaceAfter Eros Mandir shows Sholay
22MetroPlaceBefore Metro Opera House shows Shor
Sheet3


After:

Book1
OPQR
1Theater:
2Movie:
3
4
5TITLE1
6
7ErosEros:4Eros: Dunn
8ErosPlace4After Eros Strand shows Abba.
9ErosPlace4After Eros Mandir shows Sholay
10RegalRegal:4Regal: Superman
11MetroPlace4Before Metro Roxi shows Cars.
12MetroPlace4Before Metro Opera House shows Shor
13MetroMetro:4Metro: Batman
14MinervaMinerva:4Minerva: Starwars
15
16
17TITLE2
18Eros shows Superman nextweek. Delim4.
19Metro shows Dunn next month. Delim3. Closed today.
20Delim2. Minerva is showing Abba.
21MetroPlace4Before Metro Roxi shows Cars.
22ErosPlace4After Eros Strand shows Abba.
23ErosPlace4After Eros Mandir shows Sholay
24MetroPlace4Before Metro Opera House shows Shor
Sheet3
 
Upvote 0
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

zookeepertx
  • Question
Having trouble "deciphering" some code so I can see how it works
Replies
7
Views
167
zookeepertx
zookeepertx
rjplante
  • Solved
Loop Count Math issue
Replies
6
Views
90
Akuini
Akuini
G
  • Solved
Format & Protect range of cells using VBA
Replies
7
Views
430
Gajendran Yadhav
G
I
  • Solved
Using InStr to Find Matches Between Columns
Replies
1
Views
616
Farscape2020
F
B
  • Solved
Find column and delete rows below....
2
Replies
11
Views
669
Alex Blakenburg
A

Forum statistics

Threads
1,216,500
Messages
6,131,015
Members
449,615
Latest member
Nic0la

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top