Get color in the first cell and remove all other cells color

rajeshn_in · Jan 17th 2018

Hi friends,

I don't know the exact subject line.

With another vba, I am getting color in Column A based on another cell value, But I am getting color in multiple cells with the same number. I want to get color in the first cell (based on cell value) and remove all other cells color.
Please see attachment for better understanding.

Thank you.

Tom.Jones · Jan 17th 2018

You posted file without VBA code. What we modify?
You can do that without VBA code. Use conditional formatting.

Mumps · Jan 17th 2018

Try:

Code

Sub GetColorInFirstCell()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim rngUniques As Range
    Dim rng As Range
    Dim fVisRow As Long
    Sheets("Sheet1").Range("A2:A" & LastRow).Interior.ColorIndex = xlNone
    Sheets("Sheet1").Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range _
        ("A1:A" & LastRow), Unique:=True
    Set rngUniques = Sheets("Sheet1").Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
    If Sheets("Sheet1").AutoFilterMode = True Then Sheets("Sheet1").AutoFilterMode = False
    For Each rng In rngUniques
        Sheets("Sheet1").Range("A1:A" & LastRow).AutoFilter Field:=1, Criteria1:=rng
        fVisRow = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row
        Sheets("Sheet1").Cells(fVisRow, 1).Interior.ColorIndex = 6
    Next rng
    If Sheets("Sheet1").AutoFilterMode = True Then Sheets("Sheet1").AutoFilterMode = False
    Application.ScreenUpdating = True
End Sub

Display More

rajeshn_in · Jan 18th 2018

Thank you Mumps,

Well, I don't want every first number will be colored, I want, those first numbers, which the same second or third or etc. numbers were already colored. Please check my Post 1 attachment. My need mentioned from E2.

Thank you.

rajeshn_in · Jan 18th 2018

Finally I got a code as below :

[vba]

Sub Remove_Color3()

Dim i As Integer

Application.ScreenUpdating = False
For i = 2 To 255

If Cells(i, 1) = Cells(i + 1, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 1, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 1, 1).Font.Bold Then
Cells(i + 1, 1).Interior.ColorIndex = iNone
Cells(i + 1, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 2, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 2, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 2, 1).Font.Bold Then
Cells(i + 2, 1).Interior.ColorIndex = iNone
Cells(i + 2, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 3, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 3, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 3, 1).Font.Bold Then
Cells(i + 3, 1).Interior.ColorIndex = iNone
Cells(i + 3, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 4, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 4, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 4, 1).Font.Bold Then
Cells(i + 4, 1).Interior.ColorIndex = iNone
Cells(i + 4, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 5, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 5, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 5, 1).Font.Bold Then
Cells(i + 5, 1).Interior.ColorIndex = iNone
Cells(i + 5, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 6, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 6, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 6, 1).Font.Bold Then
Cells(i + 6, 1).Interior.ColorIndex = iNone
Cells(i + 6, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 7, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 7, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 7, 1).Font.Bold Then
Cells(i + 7, 1).Interior.ColorIndex = iNone
Cells(i + 7, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 8, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 8, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 8, 1).Font.Bold Then
Cells(i + 8, 1).Interior.ColorIndex = iNone
Cells(i + 8, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 9, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 9, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 9, 1).Font.Bold Then
Cells(i + 9, 1).Interior.ColorIndex = iNone
Cells(i + 9, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 10, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 10, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 10, 1).Font.Bold Then
Cells(i + 10, 1).Interior.ColorIndex = iNone
Cells(i + 10, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 11, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 11, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 11, 1).Font.Bold Then
Cells(i + 11, 1).Interior.ColorIndex = iNone
Cells(i + 11, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 12, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 12, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 12, 1).Font.Bold Then
Cells(i + 12, 1).Interior.ColorIndex = iNone
Cells(i + 12, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 13, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 13, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 13, 1).Font.Bold Then
Cells(i + 13, 1).Interior.ColorIndex = iNone
Cells(i + 13, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 14, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 14, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 14, 1).Font.Bold Then
Cells(i + 14, 1).Interior.ColorIndex = iNone
Cells(i + 14, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 15, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 15, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 15, 1).Font.Bold Then
Cells(i + 15, 1).Interior.ColorIndex = iNone
Cells(i + 15, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 16, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 16, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 16, 1).Font.Bold Then
Cells(i + 16, 1).Interior.ColorIndex = iNone
Cells(i + 16, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 17, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 17, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 17, 1).Font.Bold Then
Cells(i + 17, 1).Interior.ColorIndex = iNone
Cells(i + 17, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 18, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 18, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 18, 1).Font.Bold Then
Cells(i + 18, 1).Interior.ColorIndex = iNone
Cells(i + 18, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 19, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 19, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 19, 1).Font.Bold Then
Cells(i + 19, 1).Interior.ColorIndex = iNone
Cells(i + 19, 1).Font.Bold = False
End If

If Cells(i, 1) = Cells(i + 20, 1) And _
Cells(i, 1).Interior.ColorIndex = Cells(i + 20, 1).Interior.ColorIndex And _
Cells(i, 1).Font.Bold = Cells(i + 20, 1).Font.Bold Then
Cells(i + 20, 1).Interior.ColorIndex = iNone
Cells(i + 20, 1).Font.Bold = False
End If

Next i
Application.ScreenUpdating = True

End Sub
[\vba]

will anyone please try to reduce the above code please.

Thank you.

Tom.Jones · Jan 18th 2018

In first post you say...

Quote

I want to get color in the first cell (based on cell value) and remove all other cells color.

then

Quote from rajeshn_in

Thank you Mumps,

Well, I don't want every first number will be colored, I want, those first numbers, which the same second or third or etc. numbers were already colored. Please check my Post 1 attachment. My need mentioned from E2.

Thank you.

which one is correct?

You ignore my message where I mention that you can do this without VBA code.

Mumps · Jan 18th 2018

Try:

Code

Sub GetColorInFirstCell()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim rngUniques As Range
    Dim rng As Range
    Dim rng2 As Range
    Dim fVisRow As Long
    Dim lVisRow As Long
    Dim check As Boolean
    Sheets("Sheet1").Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range _
        ("A1:A" & LastRow), Unique:=True
    Set rngUniques = Sheets("Sheet1").Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
    If Sheets("Sheet1").AutoFilterMode = True Then Sheets("Sheet1").AutoFilterMode = False
    For Each rng In rngUniques
        Sheets("Sheet1").Range("A1:A" & LastRow).AutoFilter Field:=1, Criteria1:=rng
        fVisRow = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row
        lVisRow = Cells(Rows.Count, "A").End(xlUp).Row
        For Each rng2 In Sheets("Sheet1").Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
            check = False
            If rng2.Interior.ColorIndex = 6 Then
                check = True
                Exit For
            End If
        Next rng2
        If check = True Then
            Sheets("Sheet1").Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).Interior.ColorIndex = xlNone
            Sheets("Sheet1").Cells(fVisRow, 1).Interior.ColorIndex = 6
            Application.ScreenUpdating = True
        End If
    Next rng
    If Sheets("Sheet1").AutoFilterMode = True Then Sheets("Sheet1").AutoFilterMode = False
    Application.ScreenUpdating = True
End Sub

Display More

Get color in the first cell and remove all other cells color

Participate now!

Share