Sub ColorCells2()
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:A888"), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add(Range("A2:A888"), xlSortOnCellColor, xlDescending, , xlSortNormal).SortOnValue.Color = RGB(0, 0, 0)
.SortFields.Add(Range("A2:A888"), xlSortOnCellColor, xlDescending, , xlSortNormal).SortOnValue.Color = k
.SetRange Range("A1:Y888")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next k
Application.ScreenUpdating = True
End Sub
?
