Macro to Highlight First Row of Each Unique Value in Column

[powerpivotlegal]

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

 

[Trebor76]

Hi there,

Here's one way to do it:

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

 

[powerpivotlegal]

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

 

[Trebor76]

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:

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