56 Sắc cầu vòng trong excel (phần 2)

56 Sắc cầu vòng trong excel (phần 2)

VI. Tạo bảng màu, tên màu & chỉ số của 56 màu

Code:

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

VII. Hàm trả về các dạng biểu thị chỉ số màu nền của ô được chỉ định

Code:

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

VIII. Các hàm tính toán trên cơ sỏ màu nền của các ô

Code:

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

IX. Tô màu tương ứng cho các ô theo giá trị của ô:

Code:

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

X. Tìm màu nền tương ứng với màu Font

Code:

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

XI. Tìm các ô chứa giá trị chuỗi "JjWwZz"

Code:

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

XII.Tim "Jn" trong các tên cuả WorkBook , màu đỏ thì đổi thành trắng

Code:

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

XIII. Các bạn tự tìm hiểu :

Code:

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

PHP Code:

Option Explicit
Dim iDem As Integer
Sub ColorChange()Dim Dat As Date:                 Dim cRng As Range
Will make range of cells, or single cell change colors _
 at 1 second intervals (Written by OzGrid.com)
   Dat = Now
   Application.OnTime Dat + TimeValue("00:00:01"), "ColorChange"
   iDem = iDem + 1
   Set cRng = Choose(iDem, [C2], [D2], [E2], [F2], [g2], [g2])
   Range("C2:G2").Interior.ColorIndex = 0
   cRng.Interior.ColorIndex = Choose(iDem, 3, 36, 50, 7, 34, 0)
      If iDem = 6 Then
         iDem = 0
         Application.OnTime Dat + TimeValue("00:00:01"), "ColorChange", , False
      End IfEnd Sub