Find & highlight rows using VBA

**Max_excel** · 08-26-2020, 01:10 AM

Hi Experts,

I need to highlight duplicate rows based on 3 columns using VBA.

This is what I am looking for.

Compare the values in column B, F & H.
Highlight the duplicate values in column F & H. Also highlight the newest value in "Green" in column L & M based on the date in column B. I've attached a sample spreadsheet.

I tried using the conditional formatting with formula but my spreadsheet is freezing and lands in to recovery mode. The file has more than 10000 rows.

**nankw83** · 08-26-2020, 04:56 AM

Hi Max_excel,

Try below code based on your sample file ...

Sub test()

Dim Lc&, a, j$
Lc = Cells(1, Columns.Count).End(1).Column + 1
a = Cells(1).CurrentRegion

With CreateObject("scripting.dictionary")
   For x = 2 To UBound(a)
      j = Join(Array(a(x, 6), a(x, 8)), "-")
      If Not .exists(j) Then
         .Add j, 1 & "|" & a(x, 2)
      Else
         .Item(j) = Split(.Item(j), "|")(0) + 1 & "|" & IIf(Split(.Item(j), "|")(1) < a(x, 2), Split(.Item(j), "|")(1), a(x, 2))
      End If
   Next
   For x = 2 To UBound(a)
      j = Join(Array(a(x, 6), a(x, 8)), "-")
      a(x, 3) = IIf(Split(.Item(j), "|")(0) > 1, Split(.Item(j), "|")(0), "-")
      a(x, 4) = IIf(Split(.Item(j), "|")(0) > 1, Split(.Item(j), "|")(1), "-")
   Next
   Cells(1, Lc).Resize(UBound(a), 2) = Application.Index(a, Evaluate("row(1:" & UBound(a) & ")"), Array(3, 4))
End With

For x = 2 To UBound(a)
   If Cells(x, Lc) <> "-" Then
      Union(Cells(x, "F"), Cells(x, "H")).Interior.Color = vbRed
      If Cells(x, "B") = Cells(x, Lc).Offset(, 1) Then Union(Cells(x, "L"), Cells(x, "O")).Interior.Color = 5296274
   End If
Next

Columns(Lc).Resize(, 2).ClearContents

End Sub

**Max_excel** · 08-26-2020, 05:44 AM

Hi nankw8,

Thanks for the code it works like charm.

However, I missed to inform that Rows 1 & 2 are merged as these are the headers, these rows doesn't require to highlight duplicates. Also, column O has formula and is being removed when I run this code.

**nankw83** · 08-26-2020, 05:58 AM

Can you post a sample file that mimics your original file along with the merge cells so I can adjust the code accordingly

**Sintek** · 08-26-2020, 06:10 AM

Another Option...

Sub sintek()
Dim Data, X, i As Long, rw As Long
Application.ScreenUpdating = False
With Sheets("Sheet1").Cells(1).CurrentRegion
    Data = .Value
    For i = 2 To UBound(Data)
        rw = Evaluate("=MAX(if(" & .Columns(6).Address & "=""" & Data(i, 6) & """,IF(" & .Columns(8).Address & "=" & Data(i, 8) & ",ROW(" & .Columns(2).Address & "))))")
        X = Evaluate("=COUNTIFS(" & .Columns(6).Address & ",""" & Data(i, 6) & """, " & .Columns(8).Address & ", """ & Data(i, 8) & """)")
        If X > 1 Then With .Parent: Union(Range("F" & i), .Range("H" & i)).Interior.Color = vbRed: Union(.Range("L" & rw), .Range("O" & rw)).Interior.Color = vbGreen: End With
    Next i
End With
Application.ScreenUpdating = True
End Sub

**Max_excel** · 08-26-2020, 06:16 AM

Sure, I've attached the sample file "Sample_Find Duplicate"

**Sintek** · 08-26-2020, 06:23 AM

For my code just change 2 to 3

For i = 2 To UBound(Data)

PS...Are you guys also experiencing issues with the Forums Layout & View....
Untitled.png

**nankw83** · 08-26-2020, 06:59 AM

Originally Posted by sintek

PS...Are you guys also experiencing issues with the Forums Layout & View....

Yes, I am having the same issue

**nankw83** · 08-26-2020, 06:29 AM

Code revised ...

Sub test()

Dim Lc&, a, j$
Lc = Cells(2, Columns.Count).End(1).Column + 1
a = Cells(1).CurrentRegion.Offset(1)

With CreateObject("scripting.dictionary")
   For x = 2 To UBound(a)
      j = Join(Array(a(x, 6), a(x, 8)), "-")
      If Not .exists(j) Then
         .Add j, 1 & "|" & a(x, 2)
      Else
         .Item(j) = Split(.Item(j), "|")(0) + 1 & "|" & IIf(Split(.Item(j), "|")(1) < a(x, 2), Split(.Item(j), "|")(1), a(x, 2))
      End If
   Next
   For x = 2 To UBound(a)
      j = Join(Array(a(x, 6), a(x, 8)), "-")
      a(x, 3) = IIf(Split(.Item(j), "|")(0) > 1, Split(.Item(j), "|")(0), "-")
      a(x, 4) = IIf(Split(.Item(j), "|")(0) > 1, Split(.Item(j), "|")(1), "-")
   Next
   Cells(2, Lc).Resize(UBound(a), 2) = Application.Index(a, Evaluate("row(1:" & UBound(a) & ")"), Array(3, 4))
End With

For x = 3 To UBound(a)
   If Cells(x, Lc) <> "-" Then
      Union(Cells(x, "F"), Cells(x, "H")).Interior.Color = vbRed
      If Cells(x, "B") = Cells(x, Lc).Offset(, 1) Then Union(Cells(x, "L"), Cells(x, "O")).Interior.Color = 5296274
   End If
Next

Columns(Lc).Resize(, 2).ClearContents

End Sub

**Max_excel** · 08-26-2020, 07:16 AM

Thanks so much! The last version of code does the job.

**Max_excel** · 08-26-2020, 06:50 AM

I tried your option 2 and it worked on my sample sheet. However, I get Run Time error - 1004 Application-defined or object-defined error when pasted this code on my master report. I've attached the screenshot.

Forum page is loading perfectly for me

**Sintek** · 08-26-2020, 07:17 AM

My bad...missing a Point see red dot

If X > 1 Then With .Parent: Union(.Range("F" & i), .Range("H" & i)).Interior.Color = vbRed: Union(.Range("L" & rw), .Range("O" & rw)).Interior.Color = vbGreen: End With

**Sintek** · 08-26-2020, 11:09 AM

Glad you got it sorted...tx for rep +

**nankw83** · 08-26-2020, 08:58 AM

Glad to help & thanks Max_excel for the reps

Find & highlight rows using VBA

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Find & highlight rows using VBA

Re: Find & highlight rows using VBA

Re: Find & highlight rows using VBA

Re: Find & highlight rows using VBA

Re: Find & highlight rows using VBA

Re: Find & highlight rows using VBA

Re: Find & highlight rows using VBA

Re: Find & highlight rows using VBA

Re: Find & highlight rows using VBA

Re: Find & highlight rows using VBA

Re: Find & highlight rows using VBA

Re: Find & highlight rows using VBA

Re: Find & highlight rows using VBA

Re: Find & highlight rows using VBA

Thread Information

Users Browsing this Thread

Similar Threads

Find All and highlight selected rows

Problem with macro that needs to find and highlight rows based on searching cells

Quick way to find and highlight several hundred rows of data/and add data to new column

Quick way to find and highlight multiple rows?

macro to highlight two rows, insert at first highlighted row to shift down, copy two rows

Highlight rows using indirect function to fetch highlight frequency

[SOLVED] highlight/remove highlight of rows conditional on cellvalue

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions