[HỎI] VBA đổi màu Shape theo giá trị có sẵn

member · 2/11/18

Em có file như đính kèm, trong đó có các Shape mà em đã đặt tên theo danh sách bên cạnh
Bên cạnh danh sách tên đó (các khối bê tông mà em đang làm kế hoạch), có cột ngày dự kiến và ngày thực tế thi công
Các bác có thể giúp em viết đoạn code VBA đổi màu các Shape theo ngày tháng mà em sẽ điền vào các cột theo ý như sau:
- Nếu khối nào đang là kế hoạch, chỉ có ngày dự kiến, và nếu ngày dự kiến đó ít hơn 7 ngày so với ngày hiện tại (today) thì tô màu vàng cho Shape có tên tương ứng; (ý em là lập kế hoạch tuần)
- Nếu khối nào đã đổ rồi (đã có ngày trong cột đã thi công) thì tô màu đỏ cho Shape có tên tương ứng;
- Còn lại thì giữ nguyên màu ạ

Nếu được thì các bác có thể làm cho hiển thị tên các Shape trong chính Shape đó luôn thì tốt ạ
Tất nhiên là danh sách sẽ còn nhiều, trên đây là em vẽ ví dụ vài khối thôi ạ

Em cảm ơn mọi người.
Have a great month ahead!

vanthinh3101 · 2/11/18

member đã viết:
Em có file như đính kèm, trong đó có các Shape mà em đã đặt tên theo danh sách bên cạnh
Bên cạnh danh sách tên đó (các khối bê tông mà em đang làm kế hoạch), có cột ngày dự kiến và ngày thực tế thi công
Các bác có thể giúp em viết đoạn code VBA đổi màu các Shape theo ngày tháng mà em sẽ điền vào các cột theo ý như sau:
- Nếu khối nào đang là kế hoạch, chỉ có ngày dự kiến, và nếu ngày dự kiến đó ít hơn 7 ngày so với ngày hiện tại (today) thì tô màu vàng cho Shape có tên tương ứng; (ý em là lập kế hoạch tuần)
- Nếu khối nào đã đổ rồi (đã có ngày trong cột đã thi công) thì tô màu đỏ cho Shape có tên tương ứng;
- Còn lại thì giữ nguyên màu ạ

Nếu được thì các bác có thể làm cho hiển thị tên các Shape trong chính Shape đó luôn thì tốt ạ
Tất nhiên là danh sách sẽ còn nhiều, trên đây là em vẽ ví dụ vài khối thôi ạ

Em cảm ơn mọi người.
Have a great month ahead!
View attachment 206898

Bạn dùng thử code sau:

PHP:

Private Sub Workbook_Open()
    Dim Arr(), I As Long
    
    Arr() = Range("A4", Range("A4").End(xlDown)).Resize(, 3).Value
    
    For I = 1 To UBound(Arr, 1)
        If Len(Arr(I, 3)) Then
           ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 0, 0)
        Else
            If Len(Arr(I, 2)) And Now - Arr(I, 2) < 7 Then
                ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 192, 0)
            End If
        End If
    Next I
End Sub

Mở cửa sổ Alt+F11, chọn Thisworkbook rồi copy code vào.
Khi nào bạn mở file, code sẽ tự chạy.
Chúc bạn thành công.

member · 2/11/18

vanthinh3101 đã viết:
Bạn dùng thử code sau:

PHP:

Private Sub Workbook_Open() Dim Arr(), I As Long Arr() = Range("A4", Range("A4").End(xlDown)).Resize(, 3).Value For I = 1 To UBound(Arr, 1) If Len(Arr(I, 3)) Then ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 0, 0) Else If Len(Arr(I, 2)) And Now - Arr(I, 2) < 7 Then ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 192, 0) End If End If Next I End Sub

Mở cửa sổ Alt+F11, chọn Thisworkbook rồi copy code vào.
Khi nào bạn mở file, code sẽ tự chạy.
Chúc bạn thành công.

OK rồi bác ạ, em cảm ơn bác.
Nhưng có cách nào để Macro chạy mà k0 cần phải khởi động lại Excel?
Và có thể hiện tên các Shape để dễ nhìn không ạ?

vanthinh3101 · 2/11/18

member đã viết:
OK rồi bác ạ, em cảm ơn bác.
Nhưng có cách nào để Macro chạy mà k0 cần phải khởi động lại Excel?
Và có thể hiện tên các Shape để dễ nhìn không ạ?

Bạn copy code vào Module, sau đó Assign vào 1 nút (có thể là button/shape).
Khi nào chạy thì click vào nút đó

Mã:

Sub ChangeColour()
    Dim Arr(), I As Long
    
    Arr() = Range("A4", Range("A4").End(xlDown)).Resize(, 3).Value
    
    For I = 1 To UBound(Arr, 1)
        If Len(Arr(I, 3)) Then
           ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 0, 0)
        Else
            If Len(Arr(I, 2)) And Now - Arr(I, 2) < 7 Then
                ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 192, 0)
            End If
        End If
    Next I
End Sub

member · 2/11/18

vanthinh3101 đã viết:
Bạn copy code vào Module, sau đó Assign vào 1 nút (có thể là button/shape).
Khi nào chạy thì click vào nút đó

Mã:

Sub ChangeColour() Dim Arr(), I As Long Arr() = Range("A4", Range("A4").End(xlDown)).Resize(, 3).Value For I = 1 To UBound(Arr, 1) If Len(Arr(I, 3)) Then ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 0, 0) Else If Len(Arr(I, 2)) And Now - Arr(I, 2) < 7 Then ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 192, 0) End If End If Next I End Sub

OK rồi bác ạ;
nhưng giờ lại có 1 phát sinh như thế này;
đó là bác có thể sửa hộ em chút là nếu ô nào có ngày thực tế thì sẽ tô màu đỏ luôn, k0 cần biết là ngày thực tế trước hay sau ngày kế hoạch
Vì có trường hợp ngày thực tế trước ngày dự kiến, nên ô đó vẫn được tô màu vàng
Cảm ơn bác nhiều nhiều

member · 5/11/18

@vanthinh3101 bác sửa hộ em với ạ

vanthinh3101 · 5/11/18

member đã viết:
OK rồi bác ạ;
nhưng giờ lại có 1 phát sinh như thế này;
đó là bác có thể sửa hộ em chút là nếu ô nào có ngày thực tế thì sẽ tô màu đỏ luôn, k0 cần biết là ngày thực tế trước hay sau ngày kế hoạch
Vì có trường hợp ngày thực tế trước ngày dự kiến, nên ô đó vẫn được tô màu vàng
Cảm ơn bác nhiều nhiều

Bạn chỉ có 3 cột là: Khối, Ngày dự kiến, Ngày đổ.
Vậy ngày thực tế là ngày nào, ở cột nào?
Ngày kế hoạch và ngày dự kiến là cùng 1 ngày đúng không?

member · 5/11/18

vanthinh3101 đã viết:
Bạn chỉ có 3 cột là: Khối, Ngày dự kiến, Ngày đổ.
Vậy ngày thực tế là ngày nào, ở cột nào?
Ngày kế hoạch và ngày dự kiến là cùng 1 ngày đúng không?

Vâng, dự kiến hay kế hoạch là 1
Còn ngày thực tế với ngày đổ là 1 đó ạ

vanthinh3101 · 5/11/18

member đã viết:
Vâng, dự kiến hay kế hoạch là 1
Còn ngày thực tế với ngày đổ là 1 đó ạ

Vậy code trên đã đáp ứng yêu cầu rồi bạn nhé!
Bạn chạy thử lại đi.

member · 5/11/18

vanthinh3101 đã viết:
Vậy code trên đã đáp ứng yêu cầu rồi bạn nhé!
Bạn chạy thử lại đi.

À vâng, sáng nay em chưa thử, h thử thì thấy ok rồi ạ

Nhờ bác sửa giúp em một chút là nếu ô nào không có ngày dự kiến cũng như ngày đổ thì sẽ chuyển sang màu trắng hay màu mặc định được không ạ?
Em đã bắt đầu dùng để làm tiến độ, thì có trường em em điền ngày dự kiến nhầm ô, nên ô đó bị tô màu, sau xóa đi và chạy lại thì ô đó vẫn giữ nguyên màu đó
Cảm ơn bác!
Chúc bác tuần mới vui vẻ ạ!

vanthinh3101 · 5/11/18

member đã viết:
À vâng, sáng nay em chưa thử, h thử thì thấy ok rồi ạ

Nhờ bác sửa giúp em một chút là nếu ô nào không có ngày dự kiến cũng như ngày đổ thì sẽ chuyển sang màu trắng hay màu mặc định được không ạ?
Em đã bắt đầu dùng để làm tiến độ, thì có trường em em điền ngày dự kiến nhầm ô, nên ô đó bị tô màu, sau xóa đi và chạy lại thì ô đó vẫn giữ nguyên màu đó
Cảm ơn bác!
Chúc bác tuần mới vui vẻ ạ!

Gửi bạn

PHP:

Sub ChangeColourShapes()
    Dim Arr(), I As Long
    
    Arr() = Range("A4", Range("A4").End(xlDown)).Resize(, 3).Value
    
    For I = 1 To UBound(Arr, 1)
        If Len(Arr(I, 2)) = 0 And Len(Arr(I, 3)) = 0 Then
            ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 255, 255)
        Else
            If Len(Arr(I, 3)) Then
                ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 0, 0)
            Else
                If Len(Arr(I, 2)) And Now - Arr(I, 2) < 7 Then
                    ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 192, 0)
                End If
            End If
        End If
    Next I
End Sub

member · 5/11/18

vanthinh3101 đã viết:
Gửi bạn

Em sửa một chút code của bác để hợp với bố cục mới của em như thế này:

PHP:

Sub ChangeColourShapes()
    Dim Arr(), I As Long
    
    Arr() = Range("B5", Range("B5").End(xlDown)).Resize(, 6).Value
    
    For I = 1 To UBound(Arr, 1)
        If Len(Arr(I, 5)) = 0 And Len(Arr(I, 6)) = 0 Then
            ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 255, 255)
        Else
            If Len(Arr(I, 6)) Then
                ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 0, 0)
            Else
                If Len(Arr(I, 5)) And Now - Arr(I, 5) < 7 Then
                    ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 192, 0)
                End If
            End If
        End If
    Next I
End Sub

Em chỉ sửa mỗi ô tham chiếu A4 thành B5 và mấy chỗ offset sang (em đoán thế), và cái code trước thì không vấn đề gì, chạy ngon lành
Nhưng cái đoạn code này thì Excel báo lỗi bác ạ
Và báo lỗi ở cái dòng này ạ: ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 255, 255)
không biết em còn cần phải sửa thêm chỗ nào nữa không ạ

vanthinh3101 · 5/11/18

member đã viết:
Em sửa một chút code của bác để hợp với bố cục mới của em như thế này:

PHP:

Sub ChangeColourShapes() Dim Arr(), I As Long Arr() = Range("B5", Range("B5").End(xlDown)).Resize(, 6).Value For I = 1 To UBound(Arr, 1) If Len(Arr(I, 5)) = 0 And Len(Arr(I, 6)) = 0 Then ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 255, 255) Else If Len(Arr(I, 6)) Then ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 0, 0) Else If Len(Arr(I, 5)) And Now - Arr(I, 5) < 7 Then ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 192, 0) End If End If End If Next I End Sub

Em chỉ sửa mỗi ô tham chiếu A4 thành B5 và mấy chỗ offset sang (em đoán thế), và cái code trước thì không vấn đề gì, chạy ngon lành
Nhưng cái đoạn code này thì Excel báo lỗi bác ạ
Và báo lỗi ở cái dòng này ạ: ActiveSheet.Shapes(Arr(I, 1)).Fill.ForeColor.RGB = RGB(255, 255, 255)
không biết em còn cần phải sửa thêm chỗ nào nữa không ạ

Theo như code của bạn thì vị trí các cột như sau:
- Tên Shape: cột B
- Ngày dự kiến: cột F
- Ngày hoàn thành: cột G

member · 5/11/18

vanthinh3101 đã viết:
Theo như code của bạn thì vị trí các cột như sau:
- Tên Shape: cột B
- Ngày dự kiến: cột F
- Ngày hoàn thành: cột G

Đúng ạ

vanthinh3101 · 5/11/18

member đã viết:
Đúng ạ

Vậy màn hình báo lỗi thế nào?
Kiểu này tôi làm thầy bói mất

member · 5/11/18

vanthinh3101 đã viết:
Vậy màn hình báo lỗi thế nào?
Kiểu này tôi làm thầy bói mất

Báo như thế này bác ạ

Sau khi em bấm Debug thì nó báo ntn

vanthinh3101 · 5/11/18

member đã viết:
Báo như thế này bác ạ
View attachment 207081

Sau khi em bấm Debug thì nó báo ntn
View attachment 207083

Code bị lỗi do có 1 số dòng ở cột B (Khối) không có shape được đặt tên tương ứng (tôi đã bôi vàng trong file)
Giải pháp:
- Mở rộng mảng Arr thêm 1 cột nữa (bắt đầu từ cột A - cột G)
- Thêm 1 điều kiện so sánh cột A: nếu cột A có giá trị là "-" thì mới xét các điều kiện tiếp theo.
- Điều chỉnh lại các phần tử của mảng Arr tương ứng với mảng đã mở rộng thêm
Lưu ý: tại cột B, hàng nào có tên của shape, hàng tương ứng ở cột A phải có giá trị là "-"

member · 5/11/18

vanthinh3101 đã viết:
Code bị lỗi do có 1 số dòng ở cột B (Khối) không có shape được đặt tên tương ứng (tôi đã bôi vàng trong file)
Giải pháp:
- Mở rộng mảng Arr thêm 1 cột nữa (bắt đầu từ cột A - cột G)
- Thêm 1 điều kiện so sánh cột A: nếu cột A có giá trị là "-" thì mới xét các điều kiện tiếp theo.
- Điều chỉnh lại các phần tử của mảng Arr tương ứng với mảng đã mở rộng thêm
Lưu ý: tại cột B, hàng nào có tên của shape, hàng tương ứng ở cột A phải có giá trị là "-"

Hehe, ngon rồi bác ạ!
Cảm ơn bác nhiều

[HỎI] VBA đổi màu Shape theo giá trị có sẵn

Thành viên chính thức

File đính kèm

Thành viên tích cực

Thành viên chính thức

Thành viên tích cực

Thành viên chính thức

Thành viên chính thức

Thành viên tích cực

Thành viên chính thức

Thành viên tích cực

Thành viên chính thức

Thành viên tích cực

Thành viên chính thức

Thành viên tích cực

Thành viên chính thức

Thành viên tích cực

Thành viên chính thức

File đính kèm

Thành viên tích cực

File đính kèm

Thành viên chính thức

Đếm ngược thời gian