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
******
RNikolai001Asked:
Who is Participating?
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
RNikolai001Author 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
The Ultimate Tool Kit for Technolgy Solution Provi

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy for valuable how-to assets including sample agreements, checklists, flowcharts, and more!

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
RNikolai001Author 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
RNikolai001Author 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
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.