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
In the most complex examples, it can have 15 or so rows with 1 to 3 blank rows in between. All random.
 
Upvote 0

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Would you ever encounter something like this where the 9s are not together?
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
149Eros shows Superman nextweek. Delim4.
159Metro shows Dunn next month. Delim3. Closed today.
16
17
185Eros shows Superman nextweek.
195Metro shows Dunn next month.
20
21TITLE2
229Delim2. Minerva is showing Abba.
Sheet1
 
Upvote 0
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.
 
Upvote 0
Try this on a COPY. Since you're deleting blank rows in R. It'll also delete your delimiters in U.
VBA Code: 
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
 
Upvote 0
Thank you.I removed all blanks and tried it. Got the following error:


Rich (BB code): 
    ReDim foundWords(1 To UBound(dataR, 1), 1 To 1)
 
Upvote 0
@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.
 
Upvote 0
I forgot you wanted to remove the delims.
Try this.
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("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
QR
1Theater:
2Movie:
3TITLE1
44Eros: Dunn
54Strand shows Abba.
64Regal: Superman
74Roxi shows Cars.
84Metro: Batman
94Minerva: Starwars
105Eros shows Superman nextweek.
115Metro shows Dunn next month.
12TITLE2
139Minerva is showing Abba.
149Metro shows Dunn next month. Closed today.
159Eros shows Superman nextweek.
Sheet3
 
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