Code VBA để đổi màu Shape theo điều kiện

noppp · 22/5/24

Dạ em chào mọi người!
Em có 1 file thế này, Em muốn đổi màu Shape theo điều kiện bằng VBA
- Điều kiện là khi cột D="Đủ ngày" thì shape tương ứng nó sẽ đổi thành màu vàng
- Điều kiện là khi cột D="Quá ngày" thì shape tương ứng nó sẽ đổi thành màu đỏ
- Điều kiện là khi cột D="Chưa đủ ngày" thì shape tương ứng nó sẽ đổi thành màu xanh
Tks mọi người rất nhiều ạ

BuiQuangThuan · 22/5/24

Có 3 lô mà có 2 cái shape thôi à?

huhumalu · 22/5/24

Mình không phải cao nhân. Cố gắng sửa lại tiêu đề và tuân thủ nội quy diễn đàn.
Bạn xem thử cách củ cuối sau nhé, code đặt trong sheet nhé.

PHP:

Private Sub Worksheet_Activate()
Dim i&, lastRow&
Dim myshape As Shape
lastRow = Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lastRow
        On Error Resume Next
        Set myshape = ActiveSheet.Shapes(Range("A" & i).Value)
        On Error GoTo 0
        If Not myshape Is Nothing Then
                With myshape.Fill
                    .Visible = msoTrue
                    If Range("D" & i).Value = "Quá ngày" Then .ForeColor.RGB = RGB(255, 0, 0)
                    If Range("D" & i).Value = ChrW(272) & ChrW(7911) & " ngày" Then .ForeColor.RGB = RGB(255, 255, 0)
                    If Range("D" & i).Value = "Ch" & ChrW(432) & "a " & ChrW(273) & ChrW(7911) & " ngày" Then .ForeColor.RGB = RGB(0, 255, 0)
                End With
        End If
    Next i
End Sub

Có thể cải tiến bắt sự kiện thay đổi trong bảng tính, kiểm tra dòng thay đổi và đổi shape tương ứng tại dòng đó.

noppp · 22/5/24

huhumalu đã viết:
Mình không phải cao nhân. Cố gắng sửa lại tiêu đề và tuân thủ nội quy diễn đàn.
Bạn xem thử cách củ cuối sau nhé, code đặt trong sheet nhé.

PHP:

Private Sub Worksheet_Activate() Dim i&, lastRow& Dim myshape As Shape lastRow = Range("A" & Rows.Count).End(xlUp).Row For i = 2 To lastRow On Error Resume Next Set myshape = ActiveSheet.Shapes(Range("A" & i).Value) On Error GoTo 0 If Not myshape Is Nothing Then With myshape.Fill .Visible = msoTrue If Range("D" & i).Value = "Quá ngày" Then .ForeColor.RGB = RGB(255, 0, 0) If Range("D" & i).Value = ChrW(272) & ChrW(7911) & " ngày" Then .ForeColor.RGB = RGB(255, 255, 0) If Range("D" & i).Value = "Ch" & ChrW(432) & "a " & ChrW(273) & ChrW(7911) & " ngày" Then .ForeColor.RGB = RGB(0, 255, 0) End With End If Next i End Sub

Có thể cải tiến bắt sự kiện thay đổi trong bảng tính, kiểm tra dòng thay đổi và đổi shape tương ứng tại dòng đó.

Dạ mình có copy thử qua nhưng chưa thấy hoạt động, có thể cho mình xin file chạy thử được không ạ!

Bài đã được tự động gộp: 22/5/24

BuiQuangThuan đã viết:
Có 3 lô mà có 2 cái shape thôi à?

Dạ em có gửi lại file đính kèm rồi á a

huhumalu · 22/5/24

noppp đã viết:
Dạ mình có copy thử qua nhưng chưa thấy hoạt động, có thể cho mình xin file chạy thử được không ạ!

Bạn tạo thêm 1 sheets nữa trong file, rồi bấm qua bấm lại giữa 2 sheets để thấy khác biệt nha. Khi bấm vào sheet1 thì là active nó do sự kiện Worksheet_Activate();
Cách này cũng hơi bất cập chỗ này.

BuiQuangThuan · 22/5/24

noppp đã viết:
Dạ em có gửi lại file đính kèm rồi á a

Thế vài bữa có thêm LO nữa mà có 2 lô quá hạn thì cái shape đó nó hiện cái tên của lô nào?

huhumalu · 22/5/24

BuiQuangThuan đã viết:
Thế vài bữa có thêm LO nữa mà có 2 lô quá hạn thì cái shape đó nó hiện cái tên của lô nào?

Này chắc chỉ một phần nhỏ của bài toán siêu to khổng lồ thôi.
Bài này chắc Conditional Formatting chắc là ổn nhất, nhưng không theo ý của người hỏi thôi.

noppp · 22/5/24

BuiQuangThuan đã viết:
Thế vài bữa có thêm LO nữa mà có 2 lô quá hạn thì cái shape đó nó hiện cái tên của lô nào?

Dạ

huhumalu đã viết:
Này chắc chỉ một phần nhỏ của bài toán siêu to khổng lồ thôi.
Bài này chắc Conditional Formatting chắc là ổn nhất, nhưng không theo ý của người hỏi thôi.

Dạ nếu phát sinh thêm 1 lô trùng điều kiện nữa thì nó bị lỗi ạ

cantl · 22/5/24

Ý bạn ấy muốn hỏi là nếu có 99 lô thì phải tạo 99 shape hả? Hay là sẽ bao lô để cho chắc ăn? --=0

noppp · 23/5/24

cantl đã viết:
Ý bạn ấy muốn hỏi là nếu có 99 lô thì phải tạo 99 shape hả? Hay là sẽ bao lô để cho chắc ăn?

Đúng rồi ạ

mình muốn số lượng shape không giới hạn

anhdepjai · 23/5/24

Shape ko giới hạn, sau này khi thao tác với file sẽ bị giật đấy.

noppp · 23/5/24

anhdepjai đã viết:
Shape ko giới hạn, sau này khi thao tác với file sẽ bị giật đấy.

Dạ có phương án nào để chạy được không ạ

VetMini · 23/5/24

noppp đã viết:
Dạ có phương án nào để chạy được không ạ

Màu mè có tỷ lệ nghịch với hiệu quả (tốc độ) của bảng tính.
Chỉ chọn được 1 thôi.
Muốn được cả hai cần trình độ sử dụng bảng tính rất cao. Nếu bạn cứ lẩn quẩn cái kiểu hoa lá cành vặt vãnh này thì còn lâu lắm mới tới trình độ sử dụng bảng tính hiệu quả.

noppp · 23/5/24

VetMini đã viết:
Màu mè có tỷ lệ nghịch với hiệu quả (tốc độ) của bảng tính.
Chỉ chọn được 1 thôi.
Muốn được cả hai cần trình độ sử dụng bảng tính rất cao. Nếu bạn cứ lẩn quẩn cái kiểu hoa lá cành vặt vãnh này thì còn lâu lắm mới tới trình độ sử dụng bảng tính hiệu quả.

mình đang muốn dùng shape để vẽ tạo thành một bản đồ hiện trạng trồng mới + thu hoạch cây nông nghiệp có nhiều lô/thửa nên cần yêu cầu thế ạ :d không phải màu mè, vặt vãnh đâu ạ

ongke0711 · 23/5/24

noppp đã viết:
mình đang muốn dùng shape để vẽ tạo thành một bản đồ hiện trạng trồng mới + thu hoạch cây nông nghiệp có nhiều lô/thửa nên cần yêu cầu thế ạ :d không phải màu mè, vặt vãnh đâu ạ

Qui trình xử lý của bạn như thế nào?
1. Khi nhập thông tin lô mới --> code tự động tạo ra cái shape mới có "Name" trùng tên lô. Hoặc.
2. Bạn tự vẽ cái Shape rồi nhập thuộc tính Name của nó trùng với tên lô?

Xem thử file này.

JavaScript:

Option Explicit

Private Sub Workbook_Open()
    'Khi open se kiem tra tinh trang theo ngay mo WB va cap nhat shape color
    initializeShapesColor Sheets("Sheet1")
End Sub

JavaScript:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range(Columns(cotTinhTrangIndex - 1).Address)) Is Nothing Then 'Chi cap nhat khi cot Ngay thay doi
        initializeShapesColor ActiveSheet
    End If
End Sub

JavaScript:

Option Explicit

Public Const cotLoIndex             As Long = 1
Public Const cotTinhTrangIndex      As Long = 4
Public Const dongDau                As Long = 2

Sub initializeShapesColor(ws As Worksheet)
    Dim rng As Range, cell As Range
    Dim cellAddress As String, lastRow As Long
    Dim dict As Scripting.Dictionary

    cellAddress = ws.Cells(dongDau, cotLoIndex).Address
    lastRow = ws.Cells(ws.Rows.Count, ws.Range(cellAddress).Column).End(xlUp).Row
    Set rng = ws.Range(ws.Cells(dongDau, cotLoIndex), ws.Cells(lastRow, cotLoIndex))

    Set dict = New Scripting.Dictionary
    For Each cell In rng
        If Not dict.Exists(cell.Value) Then
            dict.Add cell.Value, Cells(Range(cell.Address).Row, 4)  'Key: cot Lo, Item: tinh trang
        End If
    Next cell

    '-----------------------------------------
    ' Cap nhat Shape color
    Dim key As Variant, myShape As Shape
    For Each key In dict.Keys
        On Error Resume Next
        Set myShape = ws.Shapes(key)
        If Not myShape Is Nothing Then
            With myShape.Fill
                Select Case dict(key)
                Case "Quá ngày"
                    .ForeColor.RGB = RGB(255, 0, 0)
                Case ChrW(272) & ChrW(7911) & " ng" & ChrW(224) & "y"   'Du ngay
                    .ForeColor.RGB = RGB(255, 255, 0)
                Case "Ch" & ChrW(432) & "a " & ChrW(273) & ChrW(7911) & " ng" & ChrW(224) & "y"    'Chua du ngày
                    .ForeColor.RGB = RGB(154, 205, 50) 'RGB(173, 255, 47)

                End Select
            End With
        End If
    Next key

    Set dict = Nothing
    
End Sub

noppp · 24/5/24

ongke0711 đã viết:

Qui trình xử lý của bạn như thế nào?
1. Khi nhập thông tin lô mới --> code tự động tạo ra cái shape mới có "Name" trùng tên lô. Hoặc.
2. Bạn tự vẽ cái Shape rồi nhập thuộc tính Name của nó trùng với tên lô?

Xem thử file này.

JavaScript:

Option Explicit

Private Sub Workbook_Open()
    'Khi open se kiem tra tinh trang theo ngay mo WB va cap nhat shape color
    initializeShapesColor Sheets("Sheet1")
End Sub

JavaScript:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range(Columns(cotTinhTrangIndex - 1).Address)) Is Nothing Then 'Chi cap nhat khi cot Ngay thay doi
        initializeShapesColor ActiveSheet
    End If
End Sub

JavaScript:

Option Explicit

Public Const cotLoIndex             As Long = 1
Public Const cotTinhTrangIndex      As Long = 4
Public Const dongDau                As Long = 2

Sub initializeShapesColor(ws As Worksheet)
    Dim rng As Range, cell As Range
    Dim cellAddress As String, lastRow As Long
    Dim dict As Scripting.Dictionary

    cellAddress = ws.Cells(dongDau, cotLoIndex).Address
    lastRow = ws.Cells(ws.Rows.Count, ws.Range(cellAddress).Column).End(xlUp).Row
    Set rng = ws.Range(ws.Cells(dongDau, cotLoIndex), ws.Cells(lastRow, cotLoIndex))

    Set dict = New Scripting.Dictionary
    For Each cell In rng
        If Not dict.Exists(cell.Value) Then
            dict.Add cell.Value, Cells(Range(cell.Address).Row, 4)  'Key: cot Lo, Item: tinh trang
        End If
    Next cell

    '-----------------------------------------
    ' Cap nhat Shape color
    Dim key As Variant, myShape As Shape
    For Each key In dict.Keys
        On Error Resume Next
        Set myShape = ws.Shapes(key)
        If Not myShape Is Nothing Then
            With myShape.Fill
                Select Case dict(key)
                Case "Quá ngày"
                    .ForeColor.RGB = RGB(255, 0, 0)
                Case ChrW(272) & ChrW(7911) & " ng" & ChrW(224) & "y"   'Du ngay
                    .ForeColor.RGB = RGB(255, 255, 0)
                Case "Ch" & ChrW(432) & "a " & ChrW(273) & ChrW(7911) & " ng" & ChrW(224) & "y"    'Chua du ngày
                    .ForeColor.RGB = RGB(154, 205, 50) 'RGB(173, 255, 47)

                End Select
            End With
        End If
    Next key

    Set dict = Nothing
   
End Sub

Dạ chuẩn quá rồi ạ
Em cảm ơn nhiều nhiều!

meomap1904 · 24/5/24

Xin chào mọi người. Em xin nhờ các anh chị chỉ giúp em cách highlight toàn bộ dòng dữ liệu có điều kiện bằng Conditional Formatting ạ. Cụ thể ở cột STUFFING TIME nếu dữ liệu là "XA LAN 1" hoặc "XA LAN 2" thì toàn bộ hàng đó sẽ highlight vàng, em đặt công thức thì kết quả chị nhận được là "XA LAN 1", nếu em add thêm new rule thì nó không highlight "XA LAN 2" mà lại ra kết quả khác. Em cảm ơn mọi người!

huhumalu · 24/5/24

meomap1904 đã viết:
Xin chào mọi người. Em xin nhờ các anh chị chỉ giúp em cách highlight toàn bộ dòng dữ liệu có điều kiện bằng Conditional Formatting ạ. Cụ thể ở cột STUFFING TIME nếu dữ liệu là "XA LAN 1" hoặc "XA LAN 2" thì toàn bộ hàng đó sẽ highlight vàng, em đặt công thức thì kết quả chị nhận được là "XA LAN 1", nếu em add thêm new rule thì nó không highlight "XA LAN 2" mà lại ra kết quả khác. Em cảm ơn mọi người!

Sẵn chủ đề nên chen vào luôn ha.
Bạn xem thử;

Hoàng Tuấn 868 · 24/5/24

meomap1904 đã viết:
Xin chào mọi người. Em xin nhờ các anh chị chỉ giúp em cách highlight toàn bộ dòng dữ liệu có điều kiện bằng Conditional Formatting ạ. Cụ thể ở cột STUFFING TIME nếu dữ liệu là "XA LAN 1" hoặc "XA LAN 2" thì toàn bộ hàng đó sẽ highlight vàng, em đặt công thức thì kết quả chị nhận được là "XA LAN 1", nếu em add thêm new rule thì nó không highlight "XA LAN 2" mà lại ra kết quả khác. Em cảm ơn mọi người!
View attachment 301072

Mình thấy thực hiện bình thường mà.

meomap1904 · 24/5/24

huhumalu đã viết:
Sẵn chủ đề nên chen vào luôn ha.
Bạn xem thử;

Hihi em cám ơn anh nha em làm được rồi, cũng sợ bị ném đá vì tiêu đề là "CODE VBA ĐỂ ĐỔI MÀU ..." nhưng em lại muốn dùng Conditional Formatting ạ

Code VBA để đổi màu Shape theo điều kiện

Thành viên mới

File đính kèm

❆❆❆❆❆❆❆❆❆❆❆❆

Thành viên tiêu biểu

Thành viên mới

File đính kèm

Thành viên tiêu biểu

❆❆❆❆❆❆❆❆❆❆❆❆

Thành viên tiêu biểu

Thành viên mới

!!! Giải thoát !!!

Thành viên mới

Thành viên thường trực

Thành viên mới

Ăn cùng góc phố

Thành viên mới

Thành viên gắn bó

File đính kèm

Thành viên mới

Thành viên mới

File đính kèm

Thành viên tiêu biểu

File đính kèm

Đăng ký hôm qua

Thành viên mới

Facebook

Group