Option Explicit
Sub colors56()  '57 colors, 0 to 56
 Const Cot = 5: Const Hang = 1
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual 'pre XL97 xlManual
Dim iZ As Long
Dim str0 As String, str As String
For iZ = 0 To 56
 Cells(iZ + Hang, 1 + Cot).Interior.ColorIndex = iZ
 Cells(iZ + Hang, 1 + Cot).Value = "[Color " & iZ & "]"
 Cells(iZ + Hang, 2 + Cot).Font.ColorIndex = iZ
 Cells(iZ + Hang, 2 + Cot).Value = "[Color " & iZ & "]"
 str0 = Right("000000" & Hex(Cells(iZ + 1, 1 + Cot).Interior.CoLor), 6)
 'Excel shows nibbles in reverse order so make it as RGB
 str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
 'generating 2 columns in the HTML table
 Cells(iZ + Hang, 3 + Cot) = "#" & str & "#" & str & ""
 Cells(iZ + Hang, 4 + Cot).Formula = "=Hex2dec(""" & Right(str0, 2) & """)"
 Cells(iZ + Hang, 5 + Cot).Formula = "=Hex2dec(""" & Mid(str0, 3, 2) & """)"
 Cells(iZ + Hang, 6 + Cot).Formula = "=Hex2dec(""" & Left(str0, 2) & """)"
 Cells(iZ + Hang, 7 + Cot) = "[Color " & iZ & "]"
Next iZ
done:
 Application.Calculation = xlCalculationAutomatic 'pre XL97 xlAutomatic
 Application.ScreenUpdating = True
End Sub

Function ShowColor(rRange As Range, Loai As String)
 Dim sColor As String
 
 sColor = Right("000000" & Hex(rRange.Interior.CoLor), 6)
 sColor = Right(sColor, 2) & Mid(sColor, 3, 2) & Left(sColor, 2)
 
 Select Case UCase$(Loai)
 Case "H"
 ShowColor = sColor
 Case "I"
 ShowColor = rRange.Interior.ColorIndex
 Case "F"
 ShowColor = rRange.Font.ColorIndex
 Case "T"
 ShowColor = "#" & sColor
 Case Else
 
 End Select 
End Function

Function ColorFunction(ColorCell As Range, rRange As Range, Optional TuyBien As String)
 Dim vResult, iCell As Range: Dim iIndex As Long, Dem As Long
'Written by Ozgrid Business Applications
'Sums or counts cells based on a specified fill color.
 
 If TuyBien = "" Then TuyBien = "T"
 iIndex = ColorCell.Interior.ColorIndex
 For Each iCell In rRange
 If iCell.Interior.ColorIndex = iIndex Then
 Dem = 1 + Dem
 vResult = WorksheetFunction.SUM(iCell, vResult)
 End If
 Next iCell
 Select Case UCase$(TuyBien)
 Case "D"
 vResult = Dem
 Case "V"
 vResult = vResult / Dem
 Case Else
 
 End Select
 ColorFunction = vResult 
End Functd9i5I 
Sub DoiMau() 
 Color_Change Selection
End Sub

Private Sub Color_Change(ByVal Target As Range) 
 Dim rgArea As Range, rgCell As Range
 Dim iColor As Integer
 ' Get the intersect of the target & the proper range
 Set Target = Intersect(Target, Range("A11:D28"))
 
 If (Not Target Is Nothing) Then ' If this intersection exists
 For Each rgArea In Target.Areas ' For each subsection of the selection 
 For Each rgCell In rgArea.Cells ' For each cell of the subsection
 If rgCell.Value < 56 And rgCell.Value > 0 Then
 rgCell.Interior.ColorIndex = Int(rgCell.Value)
 Else
 rgCell.Interior.ColorIndex = xlNone
 End If 
 
 Next rgCell, rgArea
 End If
End Sub

Sub RealInvertColors() 
 Dim Rng As Range
 Dim reD As Double, bLue As Double, gReen As Double, CoLor As Double
 
 Sheets("S2").Range("A20").Select
 Set Rng = Selection
 CoLor = Rng.Font.CoLor: MsgBox str(CoLor), , "Font Color:"
 reD = CoLor Mod 256: MsgBox str(reD), , "RED Color:"
 CoLor = (CoLor - reD) / 256: MsgBox str(CoLor), , "(Color - RED)/256:"
 gReen = CoLor Mod 256: MsgBox str(gReen), , "Green Color:"
 bLue = (CoLor - gReen) / 256: MsgBox str(bLue), , "Blue Color:"
 
 reD = 255 - reD
 gReen = 255 - gReen
 bLue = 255 - bLue
 
'  CoLor = 255 * 255 * blue + 255 * green + red
'  MsgBox str(CoLor) 
 Selection.Interior.CoLor = RGB(reD, gReen, bLue)
End Sub

Sub SelectJjWwZz()[/B]
Dim RgJjWwZz As Range, RgNext As Range, FirstAddress As Range

With ActiveSheet.Cells
 Set RgNext = .Find(What:="JjWwZz", After:=Range("A1"), LookIn:=xlValues)
 If Not RgNext Is Nothing Then 'Neu Tim Thay
 Set FirstAddress = RgNext
 Set RgJjWwZz = RgNext
 Do
 Set RgNext = .FindNext(RgNext)
 Set RgJjWwZz = Union(RgJjWwZz, RgNext)
 
 Loop While RgNext Is Nothing Or RgNext.Address <> FirstAddress.Address
 End If
End With
RgJjWwZz.Select
End Sub

Sub HighLightNames() 
 Dim Jn As Name
 
 On Error Resume Next
 For Each Jn In ThisWorkbook.Names
 If Not Range(Jn).Interior.ColorIndex = 3 Then
 Range(Jn).Interior.ColorIndex = 3
 Else: Range(Jn).Interior.ColorIndex = 0
 End If
 Next Jn
 
 On Error GoTo 0
End Sub

Sub PhAn()
 Dim StrC As String, FirstAddress As String
 Dim uRange, Jz As Integer
 
 StrC = InputBox("HAY CHON FUONG AN:")
 With Worksheets("S2").Range("A2:C25")
 Select Case UCase$(StrC)
 Case "B" 'Blanks: Count
 Set uRange = Cells.SpecialCells(xlCellTypeBlanks)
 If Not uRange Is Nothing Then
 FirstAddress = uRange.Address
 Do
 Jz = Jz + 1
 Loop While Not uRange Is Nothing And uRange.Address <> FirstAddress
 End If
 Case "C" 'Consts: Count 
 Set uRange = Cells.SpecialCells(xlCellTypeConstants, 23)
 If Not uRange Is Nothing Then
 FirstAddress = uRange.Address
 Do
 Jz = Jz + 1
 Loop While Not uRange Is Nothing And uRange.Address <> FirstAddress
 End If
 Case "F" 'Formulas => Value 5 
 Set uRange = Cells.SpecialCells(xlCellTypeFormulas, 23)
 If Not uRange Is Nothing Then
 FirstAddress = uRange.Address
 Do
 uRange.Value = 5
 Set uRange = .FindNext(uRange)
 Jz = Jz + 1
 Loop While Not uRange Is Nothing And uRange.Address <> FirstAddress
 End If
 
 Case "T" 'Find Value= 5 => '=A20'
 Set uRange = .Find("5", LookIn:=xlValues)
 If Not uRange Is Nothing Then
 FirstAddress = uRange.Address
 Do
 uRange.Value = "=$A$20"
 Set uRange = .FindNext(uRange)
 Jz = Jz + 1
 Loop While Not uRange Is Nothing And uRange.Address <> FirstAddress
 End If
 End Select
 MsgBox FirstAddress, , str(Jz)
 End With

End Sub