excel vba change cell color based on tabs color

[kelvin_9]

Hello All,

assuming i have 20 data in range A2:A21 at sheet 1 and they are same as the tabs name
i need a vba to return same color index (3, 5 and 6) in column A if tabs color was changed

example: when tabs name(220408120732319399) was changed to colorindex 5, i want cell A9(220408120732319399) change to colorindex 5 as well

thank you very much

 

[mumps]

This works for me:

Sub ColorCells()
    Application.ScreenUpdating = False
    Dim v As Variant, desWS As Worksheet, i As Long, lRow As Long, dic As Object, k As Variant
    Set desWS = Sheets("SUMMARY")
    With desWS
        lRow = .Range("A" & .Rows.count).End(xlUp).Row
        v = .Range("A2:A" & lRow).Value
        For i = LBound(v) To UBound(v)
            If Evaluate("isref('" & CStr(v(i, 1)) & "'!A1)") Then
                If Sheets(CStr(v(i, 1))).Tab.Color <> 0 Then
                    .Range("A" & i + 1).Interior.Color = Sheets(CStr(v(i, 1))).Tab.Color
                End If
            Else
                .Range("A" & i + 1).Interior.Color = vbBlack
            End If
        Next i
    End With
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To Sheets.count
        If Sheets(i).Name <> "PERSONALIZATION" And Sheets(i).Name <> "SUMMARY" Then
            If Sheets(i).Tab.Color <> False Then
                If Not dic.exists(Sheets(i).Tab.Color) Then
                    dic.Add Sheets(i).Tab.Color, Nothing
                End If
            End If
        End If
    Next i
    For Each k In dic.keys
        With Sheets("SUMMARY").Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("A2:A" & lRow), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add(Range("A2:A" & lRow), xlSortOnCellColor, xlDescending, , xlSortNormal).SortOnValue.Color = RGB(0, 0, 0)
            .SortFields.Add(Range("A2:A" & lRow), xlSortOnCellColor, xlDescending, , xlSortNormal).SortOnValue.Color = k
            .SetRange Range("A1:Y" & lRow)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    Next k
    Application.ScreenUpdating = True
End Sub

 

[kelvin_9]

This works for me:

Sub ColorCells()
    Application.ScreenUpdating = False
    Dim v As Variant, desWS As Worksheet, i As Long, lRow As Long, dic As Object, k As Variant
    Set desWS = Sheets("SUMMARY")
    With desWS
        lRow = .Range("A" & .Rows.count).End(xlUp).Row
        v = .Range("A2:A" & lRow).Value
        For i = LBound(v) To UBound(v)
            If Evaluate("isref('" & CStr(v(i, 1)) & "'!A1)") Then
                If Sheets(CStr(v(i, 1))).Tab.Color <> 0 Then
                    .Range("A" & i + 1).Interior.Color = Sheets(CStr(v(i, 1))).Tab.Color
                End If
            Else
                .Range("A" & i + 1).Interior.Color = vbBlack
            End If
        Next i
    End With
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To Sheets.count
        If Sheets(i).Name <> "PERSONALIZATION" And Sheets(i).Name <> "SUMMARY" Then
            If Sheets(i).Tab.Color <> False Then
                If Not dic.exists(Sheets(i).Tab.Color) Then
                    dic.Add Sheets(i).Tab.Color, Nothing
                End If
            End If
        End If
    Next i
    For Each k In dic.keys
        With Sheets("SUMMARY").Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("A2:A" & lRow), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add(Range("A2:A" & lRow), xlSortOnCellColor, xlDescending, , xlSortNormal).SortOnValue.Color = RGB(0, 0, 0)
            .SortFields.Add(Range("A2:A" & lRow), xlSortOnCellColor, xlDescending, , xlSortNormal).SortOnValue.Color = k
            .SetRange Range("A1:Y" & lRow)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    Next k
    Application.ScreenUpdating = True
End Sub

Hi mumps
thank you for your reply

sorry for the late reply, as far as i tried this 2 weeks, it is just prefect!!

thank you very much for your help!

 

[mumps]

You are very welcome.