56 Sắc cầu vòng trong excel

SA_DQ

/(hông là gì!
Thành viên danh dự
Tham gia ngày
8 Tháng sáu 2006
Bài viết
5,395
Được thích
9,129
Điểm
860
I. Hàm trả về chỉ số màu & ColorName của ô màu được chỉ định:
Mã:
[B]Function O_Mau(rCell As Range, Optional TenColor As Boolean)[/B]
Dim StrMau As String, iChiSo As Integer

iChiSo = rCell.Interior.ColorIndex
Select Case iChiSo
   Case 1
    StrMau = "Black"
   Case 2:                  StrMau = "White"
   Case 3:                  StrMau = "Red"
   Case 4:                  StrMau = "Bright Green"
   Case 5:                  StrMau = "Blue"
   Case 6:                  StrMau = "Yellow"
   Case 7:                  StrMau = "Pink"
   Case 8:                  StrMau = "Turqoise"
   Case 9:                  StrMau = "Dark Red"
   Case 10:                 StrMau = "Green"
   Case 11:                 StrMau = "Dark Blue"
   Case 12:                 StrMau = "Dark Yellow"
   Case 13:                 StrMau = "Violet"
   Case 14:                 StrMau = "Teal"
   Case 15:                 StrMau = "Gray-25%"
   Case 16:                 StrMau = "Gray-50%"
   
   Case 33:                 StrMau = "Sky Blue"
   Case 34:                 StrMau = "Light Turqoise"
   Case 35:                 StrMau = "Light Green"
   Case 36:                 StrMau = "Light Yellow"
   Case 37:                 StrMau = "Pale Blue"
   Case 38:                 StrMau = "Rose"
   Case 39:                 StrMau = "Lavendar"
   Case 40:                 StrMau = "Tan"
   Case 41:                 StrMau = "Light Blue"
   Case 42:                 StrMau = "Aqua"
   Case 43:                 StrMau = "Lime"
   Case 44:                 StrMau = "Gold"
   Case 45:                 StrMau = "Light Orange"
   Case 46:                 StrMau = "Orange"
   Case 47:                 StrMau = "Blue-Gray"
   Case 48:                 StrMau = "Gray-40%"
   Case 49:                 StrMau = "Dark Teal"
   Case 50:                 StrMau = "Sea Green"
   Case 51:                 StrMau = "Dark Green"
   Case 52:                 StrMau = "Olive Green"
   Case 53:                 StrMau = "Brown"
   Case 54:                 StrMau = "Plum"
   Case 55:                 StrMau = "Indigo"
   Case 56:                 StrMau = "Gray-80%"
  Case Else:                StrMau = "Custom color or no fill"
 End Select

 O_Mau = iChiSo & "- " & StrMau
 If TenColor = True Or StrMau = "Custom color or no fill" Then O_Mau = StrMau
[B]End Function[/B]
II. Đoạn mã tô màu trắng giá trị chứa trong các ô có màu nền là 41 "Light Blue":
Mã:
[B]Sub whiteONblue()[/B]
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual   [COLOR="Cyan"]'pre XL97 xlManua[/COLOR]
  Dim cell As Range
[COLOR="cyan"]  '[B]---Range("A3:N100").Select[/B][/COLOR] 
 For Each cell In Selection
    If cell.Interior.colorindex = 41 And cell.Column = 4 Then
        cell.Font.colorindex = 2  [COLOR="cyan"]'2=white, 6=yellow[/COLOR]
    End If
  Next cell
  Application.Calculation = xlCalculationAutomatic   'pre XL97 xlManua
  Application.ScreenUpdating = False
[B]End Sub[/B]
III. Đoạn mã sau đây sẽ xóa giá trị trong các ô đã được tô màu trong vùng chọn:
Mã:
[B]Sub XoaConstantsTuOMau()[/B]
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   Dim Cell As Range
   On Error Resume Next   [COLOR="Cyan"]'In case no cells in selection[/COLOR]
   Application.EnableEvents = False
   For Each Cell In Intersect(Selection, Cells.SpecialCells(xlConstants))
      If Cell.Interior.ColorIndex >= 0 Then Cell.ClearContents
   Next
   Application.EnableEvents = True
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
[B]End Sub[/B]
IV. Đoạn mã sau đây sẽ tô màu các hàng trong vùng chọn theo giá trị cột đầu trong vùng:
Mã:
[B]Sub ColorRowBasedOnCellValue()[/B]
  'David_McRitchie, 20010117
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Dim cell As Range
  For Each cell In Intersect(Selection, ActiveCell.EntireColumn, _
         ActiveSheet.UsedRange)
    Select Case cell.Value
        Case Is >= 50
            cell.EntireRow.Interior.ColorIndex = 20
        Case Is >= 40
            cell.EntireRow.Interior.ColorIndex = 37
        Case Is >= 20
            cell.EntireRow.Interior.ColorIndex = 38
        Case Is >= 0
            cell.EntireRow.Interior.ColorIndex = 36
        Case Else
            cell.EntireRow.Interior.ColorIndex = 44
    End Select
  Next cell
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = False
[B]End Sub[/B]
V. Đoạn mã sau đây sẽ tô màu nền các ô chứa công thức trong vùng chọn theo màu nền của ô mà công thức tham chiếu đến:
Mã:
[B]Sub ColorOfAssignment()[/B]
    Dim rnG As Range, celL As Range
    Set rnG = Selection
    'rng.Interior.ColorIndex = xlAutomatic   'clear color
    For Each celL In Intersect(rnG, rnG.SpecialCells(xlFormulas))
        On Error Resume Next
        celL.Interior.ColorIndex = Range(Mid(celL.Formula, 2)).Interior.ColorIndex
        On Error GoTo 0
    Next celL
[B]End Sub[/B]
 
Lần chỉnh sửa cuối:

SA_DQ

/(hông là gì!
Thành viên danh dự
Tham gia ngày
8 Tháng sáu 2006
Bài viết
5,395
Được thích
9,129
Điểm
860
(Tiếp) phần 2

VI. Tạo bảng màu, tên màu & chỉ số của 56 màu
Mã:
Option Explicit
[B]Sub colors56() [/B]     [COLOR="blue"]'57 colors, 0 to 56[/COLOR]
 Const Cot = 5:             Const Hang = 1
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual   [COLOR="blue"]'pre XL97 xlManual[/COLOR]
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  [COLOR="blue"]'pre XL97 xlAutomatic[/COLOR]
  Application.ScreenUpdating = True
[B]End Sub[/B]
VII. Hàm trả về các dạng biểu thị chỉ số màu nền của ô được chỉ định
Mã:
[b]
Function ShowColor(rRange As Range, Loai As String)[/B]
 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 
[B]End Function[/b]

VIII. Các hàm tính toán trên cơ sỏ màu nền của các ô
Mã:
[b]
Function ColorFunction(ColorCell As Range, rRange As Range, Optional TuyBien As String)[/B]
 Dim vResult, iCell As Range:                     Dim iIndex As Long, Dem As Long
[COLOR="blue"]'Written by Ozgrid Business Applications
'Sums or counts cells based on a specified fill color.[/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 
[B]End Functd9i5I 
Sub DoiMau()[/B] 	
 Color_Change Selection
[B]End Sub[/b]

IX. Tô màu tương ứng cho các ô theo giá trị của ô:
Mã:
[b]
Private Sub Color_Change(ByVal Target As Range)[/B]  
  Dim rgArea As Range, rgCell As Range
    Dim iColor As Integer
     '   [COLOR="blue"]Get the intersect of the target & the proper range[/COLOR]
    Set Target = Intersect(Target, Range("A11:D28"))
     
    If (Not Target Is Nothing) Then                 ' [COLOR="Blue"]If this intersection exists[/COLOR]
        For Each rgArea In Target.Areas             ' [COLOR="blue"]For each subsection of the selection[/COLOR]         
   For Each rgCell In rgArea.Cells         [COLOR="blue"]' For each cell of the subsection[/COLOR]
                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
[B]End Sub[/b]

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

Mã:
[b]Sub RealInvertColors()[/B]  
  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="Blue"] CoLor = 255 * 255 * blue + 255 * green + red[/COLOR]
'   [COLOR="blue"] MsgBox str(CoLor)[/COLOR]   
 Selection.Interior.CoLor = RGB(reD, gReen, bLue)
[B]End Sub[/b]
XI. Tìm các ô chứa giá trị chuỗi "JjWwZz"
Mã:
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
[B]End Sub[/b]


XII.Tim "Jn" trong các tên cuả WorkBook , màu đỏ thì đổi thành trắng
Mã:
[b]
Sub HighLightNames()[/B]  
  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
[B]End Sub[/b]


XIII. Các bạn tự tìm hiểu :
Mã:
[b]
Sub PhAn()[/B]
 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"    [COLOR="Blue"]'Consts: Count[/COLOR]     
   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"    [COLOR="blue"]'Formulas => Value 5[/COLOR]    
    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"    [COLOR="blue"]'Find Value= 5 => '=A20'[/COLOR]
        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

[B]End Sub[/B]
PHP:
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 If
End Sub

XV. http://bubblegum.parsons.edu/~tkaji/sp2001/flash/convert.html
 
Lần chỉnh sửa cuối:

SA_DQ

/(hông là gì!
Thành viên danh dự
Tham gia ngày
8 Tháng sáu 2006
Bài viết
5,395
Được thích
9,129
Điểm
860
Xếp một trường theo một trật tự màu quy định trước

Ví dụ chúng ta có 1 CSDL (cơ sở dữ liệu) của 1 cơ quan, mà trong đó [NgaySinh] đã được bôi màu;
Nhiệm vụ đề ra ta phải xếp CSDL này theo trật tự của 1 bảng màu cho trước
(Xin xem trong file đính kèm)
Sau khi chúng ta chạy macro sau, sẽ cho kết quả mĩ mãn.
Hạn chế của macro này là những ô đươc tô màu bằng Conditional Formatting là không đặng!
Hẹn sẽ sớm có bài về sắp xếp các ô màu bỡi Condituional Formatting!


PHP:
Option Explicit

Sub SortForColor()
 Dim Wz As Long, lRow As Long
 ReDim MMau(12, 2) As Integer
 Dim bBC As Byte, bJ As Byte
 
 For Wz = 1 To 12
    MMau(Wz, 1) = Cells(Wz + 1, 8).Interior.ColorIndex
    MMau(Wz, 2) = Wz
 Next Wz
 Columns("F:F").Select
 Selection.Insert shift:=xlToRight
 Selection.Interior.ColorIndex = xlNone
 Range("F1").FormulaR1C1 = "Temp"
 lRow = [E65432].End(xlUp).Row
 For Wz = 2 To lRow
    For bJ = 1 To 12
        With Range("E" & Wz)
            If .Interior.ColorIndex = MMau(bJ, 1) Then
                .Offset(, 1) = MMau(bJ, 2):     Exit For
            End If
        End With
    Next bJ
 Next
 Columns("B:G").Select
 Selection.Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:=Range("B2") _
    , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
    False, Orientation:=xlTopToBottom
 Columns("F:F").Delete shift:=xlToRight
 [F2].Select
 End Sub
 

File đính kèm

SA_DQ

/(hông là gì!
Thành viên danh dự
Tham gia ngày
8 Tháng sáu 2006
Bài viết
5,395
Được thích
9,129
Điểm
860
Hàm để lấy chỉ số màu trong các ô đã Conditional Formatting.

Sau 1 thời gian tìm kiếm có chủ đích, nay xin phép giới thiệu với các bạn hàm để rút trích chỉ số màu đã được định dạng có điều kiện trong Conditional Formatting (CF)

Để vậy, chúng ta phải xét đến hàm người dùng ActiveCondition sau đây:
(Nhằm cùng nhau nghiên cứu tiếp & sâu thêm, mình đã đánh số các dòng lệnh để tiện trong việc trích dẫn khi tìm hiểu)


PHP:
Option Explicit
Function ActiveCondition(Rng As Range) As Integer
Dim Tmp0, Tmp2, GPE As Long
Dim FC As FormatCondition

1 If Rng.FormatConditions.Count > 0 Then
    For GPE = 1 To Rng.FormatConditions.Count
3        Set FC = Rng.FormatConditions(GPE)
        Select Case FC.Type
        Case xlCellValue
6            Select Case FC.Operator
            Case xlBetween
                Tmp0 = GetStrippedValue(FC.Formula1) '*'
9                Tmp2 = GetStrippedValue(FC.Formula2)
                If IsNumeric(Tmp0) Then
11                    If CDbl(Rng.Value) >= CDbl(FC.Formula1) And _
                        CDbl(Rng.Value) <= CDbl(FC.Formula2) Then
13                        ActiveCondition = GPE:           Exit Function
                    End If
15                Else
                    If Rng.Value >= Tmp0 And Rng.Value <= Tmp2 Then
17                        ActiveCondition = GPE:             Exit Function
                End If:                   End If

19            Case xlGreater
                Tmp0 = GetStrippedValue(FC.Formula1)
21                If IsNumeric(Tmp0) Then
                    If CDbl(Rng.Value) > CDbl(FC.Formula1) Then
23                        ActiveCondition = GPE:            Exit Function
                    End If
25                Else
                    If Rng.Value > Tmp0 Then
27                        ActiveCondition = GPE:            Exit Function
                End If:                   End If

29            Case xlEqual
                Tmp0 = GetStrippedValue(FC.Formula1)
31                If IsNumeric(Tmp0) Then
                    If CDbl(Rng.Value) = CDbl(FC.Formula1) Then
33                        ActiveCondition = GPE:           Exit Function
                    End If
35                Else
                    If Tmp0 = Rng.Value Then
37                        ActiveCondition = GPE:            Exit Function
                End If:                    End If

39            Case xlGreaterEqual
                Tmp0 = GetStrippedValue(FC.Formula1)
41                If IsNumeric(Tmp0) Then
                    If CDbl(Rng.Value) >= CDbl(FC.Formula1) Then
43                        ActiveCondition = GPE:           Exit Function
                    End If
45                Else
                    If Rng.Value >= Tmp0 Then
47                        ActiveCondition = GPE:            Exit Function
                End If:                    End If
               
49            Case xlLess
                Tmp0 = GetStrippedValue(FC.Formula1)
51                If IsNumeric(Tmp0) Then
                    If CDbl(Rng.Value) < CDbl(FC.Formula1) Then
53                        ActiveCondition = GPE:           Exit Function
                    End If
55                Else
                    If Rng.Value < Tmp0 Then
57                        ActiveCondition = GPE:           Exit Function
                End If:                    End If

59            Case xlLessEqual
                Tmp0 = GetStrippedValue(FC.Formula1)
61                If IsNumeric(Tmp0) Then
                    If CDbl(Rng.Value) <= CDbl(FC.Formula1) Then
63                        ActiveCondition = GPE:            Exit Function
                    End If
65                Else
                    If Rng.Value <= Tmp0 Then
67                        ActiveCondition = GPE:            Exit Function
                End If:                    End If


69            Case xlNotEqual
                Tmp0 = GetStrippedValue(FC.Formula1)
71                If IsNumeric(Tmp0) Then
                    If CDbl(Rng.Value) <> CDbl(FC.Formula1) Then
73                        ActiveCondition = GPE:            Exit Function
                    End If
75                Else
                    If Tmp0 <> Rng.Value Then
77                        ActiveCondition = GPE:            Exit Function
                End If:                    End If

79            Case xlNotBetween
                Tmp0 = GetStrippedValue(FC.Formula1)
81                Tmp2 = GetStrippedValue(FC.Formula2)
                If IsNumeric(Tmp0) Then
83                    If Not (CDbl(Rng.Value) <= CDbl(FC.Formula1)) And _
                          (CDbl(Rng.Value) >= CDbl(FC.Formula2)) Then
                          ActiveCondition = GPE:            Exit Function
85                    End If
                Else
87                    If Not Rng.Value <= Tmp0 And _
                        Rng.Value >= Tmp2 Then
89                        ActiveCondition = GPE:            Exit Function
                End If:                    End If
             
91            Case Else
                Debug.Print "UNKNOWN OPERATOR"
93            End Select

        Case xlExpression
95            If Application.Evaluate(FC.Formula1) Then
                ActiveCondition = GPE:                       Exit Function
97            End If

        Case Else
99            Debug.Print "UNKNOWN TYPE"
        End Select
101    Next GPE
End If
103  ActiveCondition = 0

End Function
Hàm ActiveCondition được bổ trợ bỡi hàm dưới đây:

Mã:
[B]Function GetStrippedValue(CF As String) As String[/B]
    Dim Tmp As String
    If InStr(1, CF, "=", vbTextCompare) Then
       Tmp = Mid(CF, 3, Len(CF) - 3)
       If Left(Tmp, 1) = "=" Then
           Tmp = Mid(Tmp, 2)
       End If
    Else
       Tmp = CF
    End If
    GetStrippedValue = Tmp
[B]End Function[/B]
Khi trong tay chúng ta đã có công cụ trên, thì việc rút trích chỉ số màu đã ấn định trong CF chỉ còn là việc nhỏ nhoi, như hàm dưới đây:

PHP:
Function ColorIndexOfCF(Rng As Range, Optional OfFont As Boolean = False) As Integer
Dim AC As Integer

If Rng.FormatConditions.Count = 0 Then ''
    If OfFont Then
        ColorIndexOfCF = Rng.Font.ColorIndex
    Else
        ColorIndexOfCF = Rng.Interior.ColorIndex
    End If
Else
    AC = ActiveCondition(Rng)
    If OfFont Then
        ColorIndexOfCF = Rng.FormatConditions(AC).Font.ColorIndex
    Else
        ColorIndexOfCF = Rng.FormatConditions(AC).Interior.ColorIndex
    End If
End If

End Function
Các bạn cùng tôi làm chuyến khảo sát thực địa trong file đính kèm

Chú í: Hàm ActiveCondition có thể đưa ra kết quả không chính xác, nếu gặp các trường hợp sau đây:

1. Bạn gọi hàm từ worksheet cell

2. Các ô gán hàm đã được format “Formula Is” thay vì ‘Cell Value Is”.

3. Công thức dùng trong Coditional Formula chứa các địa chỉ liên kết
 

File đính kèm

tuanvina

Thành viên mới
Tham gia ngày
3 Tháng bảy 2009
Bài viết
9
Được thích
1
Điểm
0
Tuổi
29

VIII. Các hàm tính toán trên cơ sỏ màu nền của các ô
Mã:
[B]
Function ColorFunction(ColorCell As Range, rRange As Range, Optional TuyBien As String)[/B]
 Dim vResult, iCell As Range:                     Dim iIndex As Long, Dem As Long
[COLOR=blue]'Written by Ozgrid Business Applications
'Sums or counts cells based on a specified fill color.[/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 
[B]End Functd9i5I 
Sub DoiMau()[/B]     
 Color_Change Selection
[B]End Sub[/B]


Bạn ơi , mình dùng hàm này (hoặc phải thay đôi như thế nào) để tính được Tổng các gia trị chứa trong các ô có mầu cùng nhau ?
Ví dụ : trong 1 tháng mình chấm công : công thừong (màu trắng), tăng ca (mầu xanh), ca 3(mầu đỏ) vây mình phải dung hàm như thế nào mới tính được tổng công thường, tăng ca, ca 3 ?
 

HYen17

Thành viên cằn cỗi.
Tham gia ngày
27 Tháng năm 2007
Bài viết
4,489
Được thích
6,160
Điểm
100
Tuổi
19
Hàm mà bạn trích dẫn có khả năng
Đếm số ô cùng màu nền với màu nền của ô chuẩn mà bạn cung cấp (đó là tham số ColorCell)
Khi đó bạn phải cung cấp/nhập 'D' cho tham số cuối cùng của hàm
Tính trung bình của trị tại các ô cùng màu với màu nền của tham số ColorCell. Hàm này mặc nhiên tính TB, nên ta có thể không cần nhập thông số cuối cùng;

Các lưu í khi phát triển hàm:

(*) Nếu ta dùng màu font chữ, thì sửa lại các câu lệnh có từ 'Interios' => 'Font'
(*) Nếu bạn chỉ dùng màu đỏ & xanh, (tương ứng là các chỉ số màu 3 & 5; Thì thay vì xài biến iIndex, ta khai báo các Const mà xài; Ví dụ
Mã:
 Const DDo As Byte =3:              Const Xanh As Byte = 5
(*) Bạn có thể chuyển hàm 1 chút thì nó sẽ tính tổng số liệu các ô cùng màu vớ màu chuẩn cho bạn.

Hi vọng giúp được bạn ít nhiều! :-=
 

tuanvina

Thành viên mới
Tham gia ngày
3 Tháng bảy 2009
Bài viết
9
Được thích
1
Điểm
0
Tuổi
29
ban co the lam o vi du minh dinh kem !

Ban co the lam cong thuc o file minh dinh kem de minh hoa duoc ko?
Minh cam on
 

HYen17

Thành viên cằn cỗi.
Tham gia ngày
27 Tháng năm 2007
Bài viết
4,489
Được thích
6,160
Điểm
100
Tuổi
19
Hãy tuân thử nội quy của diễn đàn

Ban co the lam cong thuc o file minh dinh kem de minh hoa duoc ko?
Minh cam on
Lúc ấy mình sẽ gởi ngay file lên!

Tạm đưa lên hàm tính toán trên cơ sở màu Font trong các ô được chọn:

PHP:
Function ColorCount(ColorIndex As Byte, rRange As Range, Optional TuyBien As String)
 Dim vResult, Clls As Range:                     Dim iIndex As Long, Dem As Long
 
 If TuyBien = "" Then TuyBien = "T"
 For Each Clls In rRange
    If Clls.Font.ColorIndex = ColorIndex Then
        Dem = 1 + Dem
        vResult = WorksheetFunction.Sum(Clls, vResult)
    End If
 Next Clls
 Select Case UCase$(TuyBien)
 Case "D"
    vResult = Dem
 Case "V"
    vResult = vResult / Dem
 End Select
 ColorCount = vResult
End Function
 

File đính kèm

Lần chỉnh sửa cuối:

tuanvina

Thành viên mới
Tham gia ngày
3 Tháng bảy 2009
Bài viết
9
Được thích
1
Điểm
0
Tuổi
29
Lần chỉnh sửa cuối:

HYen17

Thành viên cằn cỗi.
Tham gia ngày
27 Tháng năm 2007
Bài viết
4,489
Được thích
6,160
Điểm
100
Tuổi
19
Thay vì:


Bạn chỉ nên là:



Và áp dụng hàm mình vừa đưa lên
Ví dụ tại 'Z2' bạn nhập =ColorCount(5, B2:W2)
Còn tại 'Y2' bạn nhập =ColorCount(3, B2:W2)

(Bạn xem thêm hàm này trong file đính kèm nha & cũng rất mong bạn tự sửa lại nội dung bài trên cho đúng theo nội quy của diễn đàn cái nha!)
 
Lần chỉnh sửa cuối:

newhope2005

Thành viên mới
Tham gia ngày
23 Tháng mười 2010
Bài viết
24
Được thích
6
Điểm
0
Tuổi
40
Các bác cho E hỏi. E muốn copy pastvalue tất cả các ô có mã màu RGB(204, 255, 255) trong vùng chọn (Hoặc cả sheet) thì dùng code nào hả các bác ơi.
Còn các ô khác vẫn giữ nguyên công thức.
Rất mong được giúp đỡ
 

newhope2005

Thành viên mới
Tham gia ngày
23 Tháng mười 2010
Bài viết
24
Được thích
6
Điểm
0
Tuổi
40
Nhân tiện đây E hỏi luôn để không phải mở thêm topic mới mà chẳng thấy ai trả lời (#11) cả.
 

gone_with_the_wind

Thành viên mới
Tham gia ngày
14 Tháng mười 2015
Bài viết
1
Được thích
0
Điểm
0
Tuổi
29
Chào bạn,
Bạn giúp mình một chút.
Trong file đính kèm mình đã làm theo các bài hướng dẫn của bạn, mình sẽ chuyển nó sang dạng Add-In. Nhưng vấn đề là mỗi khi thêm hay bớt một ô màu thì Function không tự chạy mà cứ phải Double-Click vào vùng chọn, hoặc vào công thức rồi Enter nó mới chạy.
Bạn có thể giúp mình để nó tự động chạy mỗi khi mình thêm hoặc bớt các ô có tô màu.
Cảm ơn bạn nhiều.
 

File đính kèm

long74dc

Thành viên mới
Tham gia ngày
28 Tháng chín 2007
Bài viết
4
Được thích
0
Điểm
663
Tuổi
44
Hi Chào bạn !
Mình thấy bạn có đoạn mã code
Đoạn mã sau đây sẽ xóa giá trị trong các ô đã được tô màu trong vùng chọn

Bạn cho mình hỏi vậy mình có thể tạo đoạn code lấy giá trị trong các ô đã được tô màu trong vùng dduocj chọn được không vậy bạn ?
 

Hoang2013

Thành viên gắn bó
Tham gia ngày
15 Tháng tám 2013
Bài viết
1,625
Được thích
1,594
Điểm
100
Tuổi
5
Chắc là được, nếu các ô có màu không phải do CF làm nó có màu!

Thân.
 

Hoang2013

Thành viên gắn bó
Tham gia ngày
15 Tháng tám 2013
Bài viết
1,625
Được thích
1,594
Điểm
100
Tuổi
5
Nếu được như vậy bạn có thể hướng dẫn mình được không vậy bạn ?
Đây là ví dụ để bạn có thể tham khảo:
PHP:
Sub SelectColorCellsFrom35To41()
 Dim Rng As Range, Cls As Range, cRg As Range

 Set Rng = Application.InputBox(Prompt:="Chon Vùng Càn Thiét:", Title:="Select range", Type:=8)
 If Not Rng Is Nothing Then
    For Each Cls In Rng
        With Cls.Interior
            If .ColorIndex > 34 And .ColorIndex < 42 Then
                If cRg Is Nothing Then
                    Set cRg = Cls
                Else
                    Set cRg = Union(cRg, Cls)
                End If
            End If
        End With
    Next Cls
    If Not cRg Is Nothing Then MsgBox cRg.Address
 End If
End Sub
 

lotteriamax

Thành viên mới
Tham gia ngày
29 Tháng mười 2014
Bài viết
2
Được thích
0
Điểm
163
Tuổi
28
Mình muốn đếm số màu được đánh dấu. các bạn giúp mình với.
MÀu được đánh dấu là số 1. 1 màu được đánh dấu ít nhất lần là thỏa mãn điều kiện
Mọi người giúp mình với
 

File đính kèm

Hoang2013

Thành viên gắn bó
Tham gia ngày
15 Tháng tám 2013
Bài viết
1,625
Được thích
1,594
Điểm
100
Tuổi
5
Chưa thể tiêu hóa được vấn đề của bạn:
(*) Đánh dấu hay đánh số?
(*) Màu nền của các ô hay màu Font của chúng?
(*) Với màu nền thì từng loại màu hay miễn có màu là tính?
(*) Đếm hay tính tổng các số trong các ô thỏa?
 
Top