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

SA_DQ · 12/8/06

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]

SA_DQ · 12/8/06

(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

SA_DQ · 26/5/08

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

SA_DQ · 27/5/08

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

tuanvina · 3/7/09

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 ?

SA_DQ · 3/7/09

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 · 4/7/09

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

SA_DQ · 4/7/09

Hãy tuân thử nội quy của diễn đàn

tuanvina đã viết:
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

tuanvina · 4/7/09

sao minh post file đính kèm ko đươc nhỉ ?

sao mình đã dùng công cụ file đính kèm rồi mà ko post no lên được nhỉ

Mình phải dùng Mediafire, bạn xem giùm nhé :
http://www.mediafire.com/download.php?n4mtngwmxmh

SA_DQ · 4/7/09

Thay vì:

A|B|C|D|E|F|G|H|I|. . . |X|Y|Z
Ngay|1/7|2/7|3/7|4/7|5/7|8/7|9/7|I|. . . |CgThg|TgCa|Ca3
LT Thom|8| 4T | 4T |8|10| 4C | 5T | 6C |3 . . |||
|||||

||||. . . |||

Bạn chỉ nên là:

A|B|C|D|E|F|G|H|I|. . . |X|Y|Z
Ngay|1/7|2/7|3/7|4/7|5/7|8/7|9/7|I|. . . |CgThg|TgCa|Ca3
LT Thom|8| 4 | 4 |8|10| 4 | 5 | 6 |3 . . || --=0

|

||||. . . |||

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!)

newhope2005 · 15/10/11

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 · 18/10/11

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 · 14/10/15

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.

long74dc · 10/6/17

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 · 10/6/17

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.

long74dc · 12/6/17

Hoang2013 đã viết:
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.

Hello Anh , nếu được như vậy bạn có thể hướng dẫn mình được không vậy bạn ?

Hoang2013 · 12/6/17

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 · 21/8/17

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

Hoang2013 · 21/8/17

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?

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

/(hông là gì!

/(hông là gì!

/(hông là gì!

File đính kèm

/(hông là gì!

File đính kèm

Thành viên mới

/(hông là gì!

Thành viên mới

/(hông là gì!

File đính kèm

Thành viên mới

/(hông là gì!

Thành viên mới

Thành viên mới

Thành viên mới

File đính kèm

Thành viên mới

Thành viên gắn bó

Thành viên mới

Thành viên gắn bó

Thành viên mới

File đính kèm

Thành viên gắn bó

Facebook

Group