Macro to find partial matches and fill/shade to identify

In Excel I am attempting to write a formula that will identify partial matches between rows in a column that is sorted alphabetically.

Is there a user defined function that does this?

Currently the script in the module finds exact matches and shades the second of the the duplicate cells in red.

I need the script to find partial matches and shade all cells with the partial match (not just one of the partial matches). The first 5 left most characters would probably suffice in a match.


******
FirstItem = ActiveCell.Value
   SecondItem = ActiveCell.Offset(1, 0).Value
   Offsetcount = 1
   Do While ActiveCell <> ""
      If FirstItem = SecondItem Then
        ActiveCell.Offset(Offsetcount, 0).Interior.Color = RGB(255, 0, 0)
        Offsetcount = Offsetcount + 1
        SecondItem = ActiveCell.Offset(Offsetcount, 0).Value
      Else
        ActiveCell.Offset(Offsetcount, 0).Select
        FirstItem = ActiveCell.Value
        SecondItem = ActiveCell.Offset(1, 0).Value
        Offsetcount = 1
      End If
   Loop
   ScreenUpdating = True
******
RNikolai001Data scientistAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Martin LissOlder than dirtCommented:
Change
If FirstItem = SecondItem Then

Open in new window


to something like

If Left(ActiveCell, 5) Like "*" & SecondItem & "*" Then

Open in new window


which is a match if the first 5 characters of the FirstItem are in the SecondItem. In other words "abcdefg" with match "xyzabcde" but not "axyzbcde"
0
RNikolai001Data scientistAuthor Commented:
Hmmm, it gives me a debug error on "SecondItem = ActiveCell.Offset(Offsetcount, 0).Value"

Actual error=

Run-time error 1004':
Application-defied or object-defined error


Cells are highlighted outside of the data range and it takes a really, really long time to complete the macro on 100 rows of data. Attaching a photo of what the current macro does (which I am sure you know already : ) from your vast experience record on this site).Current and proposed macro results
0
Martin LissOlder than dirtCommented:
Can you supply a sample workbook please?
0
Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

Martin LissOlder than dirtCommented:
If "Chocolate Cake" matches "Chocolate Cake 2017" I don't see why "Fruit Loops" doesn't match "Fruit Loops 2017".
0
Martin LissOlder than dirtCommented:
While waiting for your answer to my last question I went ahead and did this. Note that this code does not rely on you selecting anything.
29113125.xlsm
0
RNikolai001Data scientistAuthor Commented:
Ah, the match to be made is down the column and not across the rows. Fruit Loops does have a match in Column B, but I am looking for a partial match in the following row (since column C will be sorted alphabetically) doesn't have a partial match down Column C. If there was a Fruit Loops 2018 in the next row, there would be a match. I've attached a sample spreadsheet. The original spreadsheet has about 500 rows and the data is updated every 3 or 4 hours. A macro will be so helpful when identifying those vendors without a 2018 contract. Thank you so much for your time!
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You attached but forgot to click on Upload button. Please try it again...
0
Martin LissOlder than dirtCommented:
Replace my PartialMatch sub with this one.

Sub PartialMatch()
Dim Offsetcount As Long
Dim lngLastRow As Long
Dim lngRow As Long

Application.ScreenUpdating = False

With ActiveSheet
    lngLastRow = .Range("B1048576").End(xlUp).Row
'
    For lngRow = 2 To lngLastRow
        .Range("C1:C" & lngLastRow).AutoFilter
        .Range(.Range("C1"), .Range("C" & .Rows.Count).End(xlUp)).AutoFilter Field:=1, _
             Criteria1:="*" & Left(.Cells(lngRow, "B"), 5) & "*", Operator:=xlFilterValues
        If .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count >= 3 Then
            If .Cells(lngRow, "C") Like "*" & Left(.Cells(lngRow + 1, "B"), 5) & "*" Then
                .Cells(lngRow + 1, "C").Interior.Color = RGB(255, 0, 0)
            End If
        End If
        .Range("C1:C" & lngLastRow).AutoFilter
    Next
End With

Application.ScreenUpdating = True
End Sub

Open in new window

0
RNikolai001Data scientistAuthor Commented:
Thanks, Martin. Your script highlights the duplicate in red and compares data in the rows but is there a way to highlight both the duplicate ("2018")  and the original entry ("2017")?original and duplicate highlighted
0
Martin LissOlder than dirtCommented:
Sub PartialMatch()
Dim Offsetcount As Long
Dim lngLastRow As Long
Dim lngRow As Long

Application.ScreenUpdating = False

With ActiveSheet
    lngLastRow = .Range("B1048576").End(xlUp).Row
'
    For lngRow = 2 To lngLastRow
        .Range("C1:C" & lngLastRow).AutoFilter
        .Range(.Range("C2"), .Range("C" & .Rows.Count).End(xlUp)).AutoFilter Field:=1, _
             Criteria1:="*" & Left(.Cells(lngRow, "B"), 5) & "*", Operator:=xlFilterValues
        If .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count >= 3 Then
            ' Color all the visible column 'C' cells excedpt for the header
            .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows.Count - 1).Cells.Interior.Color = RGB(255, 0, 0)
        End If
        .Range("C1:C" & lngLastRow).AutoFilter
    Next
End With

Application.ScreenUpdating = True
End Sub

Open in new window

0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You can achieve this easily without VBA. Select the whole column and from Conditional Formatting, choose Highlight Cells Rules and then choose Duplicate Values and apply custom formatting as per your requirement or go with the default formatting if that works for you.

Refer to the following image for more details...

Duplicates.jpg
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
RNikolai001Data scientistAuthor Commented:
I must be doing something wrong. I still get debug errors.
0
Martin LissOlder than dirtCommented:
Are you using Neeraj's solution or are you using mine?
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.