Macro to Highlight First Row of Each Unique Value in Column

powerpivotlegal

New Member
Joined
May 14, 2014
Messages
30
Hello Experts,

I need help with a macro that cycles through one column ("Week-Ending Date") of a formatted table that users are updating each week to find unique values (e.g. "6/25/2016 or "7/9/2016") in that column and then highlighting the first row with that unique value up and through certain columns rather than just the entire row.

Currently, I've managed to come up with a macro (seen below) that highlights all rows for a specific value rather than highlighting only the first row of the unique value.

In addition, the macro in another thread highlights all unique values in every row/cell rather than specific column.
http://www.mrexcel.com/forum/excel-...applications-highlight-unique-values-row.html


Sub Macro1()
Const TEST_COLUMN As String = "h" '<=== change to suit
Dim LastRow As Long
Dim cell As Range
sSheetName = ActiveSheet.Name

With Worksheets(sSheetName)
LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row

For Each cell In Range("h2:h" & LastRow)
If cell.Value = "6/25/2016" Then
cell.Offset(, -7).Resize(, 11).Interior.ColorIndex = 53
Else
cell.EntireRow.Interior.ColorIndex = xlNone
End If
Next
End With

End Sub

Cheers
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Hi there,

Here's one way to do it:

Code:
Option Explicit
Sub Macro1()

    'Written by Trebor76
    'http://www.mrexcel.com/forum/excel-questions/952936-macro-highlight-first-row-each-unique-value-column.html
    
    Const strMyCol As String = "H" 'Column with data to be checked. Change to suit if necessary.

    Dim objMyUniqueEntries As Object
    Dim lngRowStart As Long, _
        lngRowEnd As Long, _
        lngMyRow As Long, _
        lngMyCounter As Long
    
    lngRowStart = 2 'Starting row number for the data. Change to suit.
    Set objMyUniqueEntries = CreateObject("Scripting.Dictionary")
    lngRowEnd = Cells(Rows.Count, strMyCol).End(xlUp).Row
    
    Application.ScreenUpdating = False
    
    For lngMyRow = lngRowStart To lngRowEnd
        If objMyUniqueEntries.exists(CStr(Range(strMyCol & lngMyRow))) = False Then
            lngMyCounter = lngMyCounter + 1
            objMyUniqueEntries.Add CStr(Range(strMyCol & lngMyRow)), lngMyCounter
            Range(strMyCol & lngMyRow).Offset(, -7).Resize(, 11).Interior.ColorIndex = 53
        Else
            Rows(lngMyRow).Interior.ColorIndex = xlNone
        End If
    Next lngMyRow
    
    Set objMyUniqueEntries = Nothing
    
    Application.ScreenUpdating = True
    
End Sub

Regards,

Robert
 
Upvote 0
Thanks Robert. The code works great except that it does not run continuously. In testing it, I have to run it each time new entries are added.

I tried wrapping it a change event macro (see below), but I get a compile error. I don't know if that's because I am already running a change event macro on Column H (see further below).

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("H:H")) Is Nothing And Target.Value <> "" Then
CODE
End If
End Sub
______________________________________________
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
If Target.Columns.Count = 16384 Then

End If

' If you update a cell in column H and the value is not blank then
If Not Intersect(Target, Range("H:H")) Is Nothing And Target.Value <> "" Then
' Disable events to prevent infinite loop issues
Application.EnableEvents = False
' Update the target value by calling the custom function and work out the last day of the week
Target.Value = dhLastDayInWeek(Target.Value)
End If

LetsContinue:
' Re-enable events
Application.EnableEvents = True

If Not Intersect(Target, Range("K:K")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
If Target.Value = "x" Or Target.Value = "X" Then
Rows(Target.Row).Hidden = True
End If
End If
Exit Sub

Whoa:
Resume LetsContinue
End Sub

Any help would be greatly appreciated.

Thanks,
James
 
Upvote 0
The code works great except that it does not run continuously. In testing it, I have to run it each time new entries are added.

Correct - you never said you wanted it run each a change in Col. H occurred?

You can only have one worksheet event so this is how I'd run my code if there's a change in col. H:

Code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("H:H")) Is Nothing And Target.Value <> "" Then
        Application.EnableEvents = False
            Call Macro1
        Application.EnableEvents = True
    End If
End Sub

You could run more macros if there's a change in Col. H simply by calling them by name as I have done with Macro1.

Regards,

Robert
 
Upvote 0

Forum statistics

Threads
1,213,568
Messages
6,114,348
Members
448,570
Latest member
rik81h

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