Tự tô màu theo điều kiện

[dangductuong2125]

Em chào các bác,
Em dùng Conditional Formatting để tô màu, nhưng không hiệu quả với File làm việc của em. Các bác xem giúp em
File chi tiết các bác xem giúp em. Em cảm ơn.

 

[cantl]

tô màu

Tớ không Conditional Formatting được cái bảng này.
Dùng tạm, code hơi lủng củng, lặp từ quá chuối, mấy con số giới hạn vùng, cột chắc tự chỉnh sửa được nhẩy?

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NgayMin&
    Application.EnableEvents = False
    Dim VungNhap As Range, Cell As Range
    Dim SaveValue$
    Set VungNhap = [E7:S12]
    NgayMin = 1000000
    If Not Intersect(Target, VungNhap) Is Nothing Then
        For Each Cell In Range(Cells(Target.Row, 5), Cells(Target.Row, 19))
            If Not IsEmpty(Cell) Then
                SaveValue = Right(Cell.Value, 6)
                On Error Resume Next
                If CLng(SaveValue) <= NgayMin Then
                    NgayMin = SaveValue
                End If
            End If
        Next
        For Each Cell In Range(Cells(Target.Row, 5), Cells(Target.Row, 19))
            If Not IsEmpty(Cell) Then
                If CLng(Right(Cell.Value, 6)) <= NgayMin Then
                    Cell.Interior.ColorIndex = 6
                Else
                    Cell.Interior.ColorIndex = 0
                End If
            Else
                Cell.Interior.ColorIndex = 0
            End If
        Next
    End If
    Application.EnableEvents = True
End Sub

 

[Phuocam]

Em chào các bác,
Em dùng Conditional Formatting để tô màu, nhưng không hiệu quả với File làm việc của em. Các bác xem giúp em
File chi tiết các bác xem giúp em. Em cảm ơn.

Thử

=RIGHT (E7,6) - AGGREGATE(15 ,6 ,RIGHT($E7:$S7,6)/($E7:$S7<>"") ,1 )= 0

 

[dangductuong2125]

Tớ không Conditional Formatting được cái bảng này.
Dùng tạm, code hơi lủng củng, lặp từ quá chuối, mấy con số giới hạn vùng, cột chắc tự chỉnh sửa được nhẩy?

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NgayMin&
    Application.EnableEvents = False
    Dim VungNhap As Range, Cell As Range
    Dim SaveValue$
    Set VungNhap = [E7:S12]
    NgayMin = 1000000
    If Not Intersect(Target, VungNhap) Is Nothing Then
        For Each Cell In Range(Cells(Target.Row, 5), Cells(Target.Row, 19))
            If Not IsEmpty(Cell) Then
                SaveValue = Right(Cell.Value, 6)
                On Error Resume Next
                If CLng(SaveValue) <= NgayMin Then
                    NgayMin = SaveValue
                End If
            End If
        Next
        For Each Cell In Range(Cells(Target.Row, 5), Cells(Target.Row, 19))
            If Not IsEmpty(Cell) Then
                If CLng(Right(Cell.Value, 6)) <= NgayMin Then
                    Cell.Interior.ColorIndex = 6
                Else
                    Cell.Interior.ColorIndex = 0
                End If
            Else
                Cell.Interior.ColorIndex = 0
            End If
        Next
    End If
    Application.EnableEvents = True
End Sub

Cảm ơn bạn nhiều nhé

 

[HeSanbi]

@dangductuong2125 không cần chế độ Undo phải không bạn?

 

[HUONGHCKT]

Em chào các bác,
Em dùng Conditional Formatting để tô màu, nhưng không hiệu quả với File làm việc của em. Các bác xem giúp em
File chi tiết các bác xem giúp em. Em cảm ơn.

Góp vui.
Bạn tham khảo code sau:
Code trong VBE/ Sheet1

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim R As Long
R = Target.Row
If R >= 7 And Target.Column >= 5 Then
   Call ToMau(R)
End If
End Sub

Code trong Module

Sub ToMau(aRow As Long)
Dim i&, Col&, M&, aCol&
Dim Cel As Range, Rng As Range, jRng As Range
Dim S
Dim sh As Worksheet
Set sh = ActiveSheet
Col = sh.Cells(aRow, Columns.Count).End(xlToLeft).Column
If sh.Cells(aRow, 5) <> Empty Then aCol = 5 Else aCol = sh.Cells(aRow, 5).End(xlToRight).Column
Set Cel = sh.Cells(aRow, aCol)
Set Rng = sh.Range(sh.Cells(aRow, 5), sh.Cells(aRow, Col))
M = Split(Cel, " ")(1)
Rng.Interior.Pattern = xlNone

For i = 1 To Rng.Columns.Count
    If Rng(1, i) <> Empty Then
        S = Split(Rng(1, i), " ")
        If S(1) <= M Then M = S(1)
    End If
Next i

For i = 1 To Rng.Columns.Count
    If Rng(1, i) <> Empty Then
        If Split(Rng(1, i), " ")(1) = M Then
            If jRng Is Nothing Then Set jRng = Rng(1, i) Else Set jRng = Union(jRng, Rng(1, i))
        End If
    End If
Next i
jRng.Interior.Color = 65535
End Sub

Xem file

 

[dangductuong2125]

Góp vui.
Bạn tham khảo code sau:
Code trong VBE/ Sheet1

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim R As Long
R = Target.Row
If R >= 7 And Target.Column >= 5 Then
   Call ToMau(R)
End If
End Sub

Code trong Module

Sub ToMau(aRow As Long)
Dim i&, Col&, M&, aCol&
Dim Cel As Range, Rng As Range, jRng As Range
Dim S
Dim sh As Worksheet
Set sh = ActiveSheet
Col = sh.Cells(aRow, Columns.Count).End(xlToLeft).Column
If sh.Cells(aRow, 5) <> Empty Then aCol = 5 Else aCol = sh.Cells(aRow, 5).End(xlToRight).Column
Set Cel = sh.Cells(aRow, aCol)
Set Rng = sh.Range(sh.Cells(aRow, 5), sh.Cells(aRow, Col))
M = Split(Cel, " ")(1)
Rng.Interior.Pattern = xlNone

For i = 1 To Rng.Columns.Count
    If Rng(1, i) <> Empty Then
        S = Split(Rng(1, i), " ")
        If S(1) <= M Then M = S(1)
    End If
Next i

For i = 1 To Rng.Columns.Count
    If Rng(1, i) <> Empty Then
        If Split(Rng(1, i), " ")(1) = M Then
            If jRng Is Nothing Then Set jRng = Rng(1, i) Else Set jRng = Union(jRng, Rng(1, i))
        End If
    End If
Next i
jRng.Interior.Color = 65535
End Sub

Xem file

Cảm ơn anh đã nhiệt tình hỗ trợ

Bài đã được tự động gộp: 18/12/23

Thử

=RIGHT (E7,6) - AGGREGATE(15 ,6 ,RIGHT($E7:$S7,6)/($E7:$S7<>"") ,1 )= 0

uh cảm ơn bạn nhiều nhé. Dữ liệu ít cũng rất hay. Của mình dữ liệu nhiều quá

 

[SA_DQ]

@Chủ bài đăng: Hình như bạn tự làm khó mình trong thiết kế CSDL;
Sao bạn có thể bắt 1 ô chứa 2 loại dữ liệu làm vậy?Đẹp thì có đẹp nhưng hao điện & nơ ron thần kinh lắm thay!