Tô màu những ô liên kết với ô hiện hành

[Excel365]

Nhờ các anh chị giúp em viết code tô màu ô liên kết với ô hiện hành. Tương tự như chức năng Trace Precedents của office để xác định những ô có liên kết với ô đang chọn. Khi rê chuột ô khác thì màu ở ô cũ loại bỏ.
Ví dụ: khi em để chuột ở ô J21 thi tô màu BC21 và ô CU21.
Trân trọng cảm ơn

 

[quocphuoc88]

Bạn thử các củ chuối này thử xem :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim r as long
    Range("BC19:BC135").Interior.Color = xlNone
    Range("CU19:CU135").Interior.Color = xlNone
    If Not Intersect(Target, Range("J19:J135")) Is Nothing Then
        If Target.Count = 1 Then
            r = Target.Row
            Cells(r, 55).Interior.Color = 5535
            Cells(r, 99).Interior.Color = 5535
        End If
    End If
End Sub

p/s: trong file bạn hiện đang có khoản 3 sheet ẩn, giống như virus !

 

[Excel365]

Bạn thử các củ chuối này thử xem :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim r as long
    Range("BC19:BC135").Interior.Color = xlNone
    Range("CU19:CU135").Interior.Color = xlNone
    If Not Intersect(Target, Range("J19:J135")) Is Nothing Then
        If Target.Count = 1 Then
            r = Target.Row
            Cells(r, 55).Interior.Color = 5535
            Cells(r, 99).Interior.Color = 5535
        End If
    End If
End Sub

p/s: trong file bạn hiện đang có khoản 3 sheet ẩn, giống như virus !

Sao mình chọn nhưng không thấy tô màu vậy bạn

 

[OverAC]

1. File của bạn có virus (hoặc dấu vết để lại của virus)
2. Dùng đoạn code này thử:

1 vài lưu ý:
- Viết nhanh chưa thử nghiệm nhiều, có thể có lỗi
- Biến các ô sau khi bị hết chỉ định thì sẽ thành màu trắng hết.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static pre_rng As Range
On Error Resume Next
    pre_rng.Interior.ColorIndex = 0
    Target.Precedents.Interior.ColorIndex = 8
    Set pre_rng = Target.Precedents
End Sub

 

[Excel365]

[video=youtube;Sv3KPAkR_JI]https://www.youtube.com/watch?v=Sv3KPAkR_JI[/video]

1. File của bạn có virus (hoặc dấu vết để lại của virus)
2. Dùng đoạn code này thử:

1 vài lưu ý:
- Viết nhanh chưa thử nghiệm nhiều, có thể có lỗi
- Biến các ô sau khi bị hết chỉ định thì sẽ thành màu trắng hết.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static pre_rng As Range
On Error Resume Next
    pre_rng.Interior.ColorIndex = 0
    Target.Precedents.Interior.ColorIndex = 8
    Set pre_rng = Target.Precedents
End Sub

Cám ơn bạn nhiều. có thể tô màu ô đang click chuột được ko bạn.
Ps: Có cách nào khắc phục được lỗi khi minh rê chuột nhiều ô để bung cột bị khuất ra thì code chạy bị chậm. phải bấm phím Esc mới hết.

 

[quocphuoc88]

Sao mình chọn nhưng không thấy tô màu vậy bạn

Trong file bạn có 1 đoạn code check cái checkbox2 gì đó thì nó mới cho sự kiện worksheetChange thực hiện. Do đó để chạy được, bạn để đoạn code của mình phía trên cái đoạn checkbox kia là ok !

 

[Excel365]

Trong file bạn có 1 đoạn code check cái checkbox2 gì đó thì nó mới cho sự kiện worksheetChange thực hiện. Do đó để chạy được, bạn để đoạn code của mình phía trên cái đoạn checkbox kia là ok !

Code của bạn chỉ đúng với cột J. những cột khác thì bị sai bạn ơi

 

[quocphuoc88]

Code của bạn chỉ đúng với cột J. những cột khác thì bị sai bạn ơi

Thì đúng rồi, mình chỉ làm trong cột J mà thôi. Thiết nghĩ nếu code đó ok thì bạn có thề từ đó suy diễn ra cho những yêu cầu khác của bạn mà !

 

[Excel365]

Thì đúng rồi, mình chỉ làm trong cột J mà thôi. Thiết nghĩ nếu code đó ok thì bạn có thề từ đó suy diễn ra cho những yêu cầu khác của bạn mà !

bạn có thể làm giúp mình luôn được ko!

 

[ndu96081631]

Bạn thử các củ chuối này thử xem :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim r as long
    Range("BC19:BC135").Interior.Color = xlNone
    Range("CU19:CU135").Interior.Color = xlNone
    If Not Intersect(Target, Range("J19:J135")) Is Nothing Then
        If Target.Count = 1 Then
            r = Target.Row
            Cells(r, 55).Interior.Color = 5535
            Cells(r, 99).Interior.Color = 5535
        End If
    End If
End Sub

Code này trật lất so với yêu cầu của tác giả nha
Yêu cầu của người ta là: Khi chọn vào 1 cell, nếu nó chứa công thức thì sẽ tô màu tất cả các cell tham chiếu của công thức ấy. Ví dụ:
- Cell J21 có công thức =IF(BC21>0,$I21*CU21,0)
- Vậy khi chọn vào cell J21 thì sẽ tô màu BC21, I21 và CU21
--------------------
Code kiểu như OverAC làm ấy

 

[Excel365]

Code này trật lất so với yêu cầu của tác giả nha
Yêu cầu của người ta là: Khi chọn vào 1 cell, nếu nó chứa công thức thì sẽ tô màu tất cả các cell tham chiếu của công thức ấy. Ví dụ:
- Cell J21 có công thức =IF(BC21>0,$I21*CU21,0)
- Vậy khi chọn vào cell J21 thì sẽ tô màu BC21, I21 và CU21
--------------------
Code kiểu như OverAC làm ấy

Em có sưu tầm được code này trên internet, nhưng khi em di chuyển chuột ra những ô khác thì thỉnh thoảng những ô cũ nó không xóa được màu, nhờo thầy chỉnh sữa giúp em
[GPECODE=vba]Public PrevSelIntColInd As Integer
Dim PrevSel As Range


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rng As Range
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set rng = Target.Precedents
On Error GoTo 0
If PrevSelIntColInd <> 0 Then
PrevSel.Interior.ColorIndex = PrevSelIntColInd
End If
If rng Is Nothing Then Exit Sub
Set PrevSel = rng
PrevSelIntColInd = rng.Interior.ColorIndex
rng.Interior.ColorIndex = 6
End Sub
[/GPECODE]

 

[quocphuoc88]

Code này trật lất so với yêu cầu của tác giả nha
Yêu cầu của người ta là: Khi chọn vào 1 cell, nếu nó chứa công thức thì sẽ tô màu tất cả các cell tham chiếu của công thức ấy. Ví dụ:
- Cell J21 có công thức =IF(BC21>0,$I21*CU21,0)
- Vậy khi chọn vào cell J21 thì sẽ tô màu BC21, I21 và CU21
--------------------
Code kiểu như OverAC làm ấy

Dạ, e cám ơn Thầy, e chưa đúng ý tác giả !

To huuduy.duy:

E xin phép mượn code của a OverAc để chỉnh sửa . Bạn coi thử được chưa nha bạn !

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static pre_rng As Range
On Error Resume Next
    pre_rng.Interior.ColorIndex = 0 'dua nhung vung luc truoc ve lai khong mau
    If Target.Count > 1 Then Exit Sub 'chi cho phep chon 1 cell
    Target.Interior.ColorIndex = 8 'to mau cho o hien hanh
    Target.Precedents.Interior.ColorIndex = 8 'to mau cho nhung o lien quan trong cong thuc
    If Target.Precedents Is Nothing Then 'neu o do khong co cong thuc toi nhung o lien quan
        Set pre_rng = Target 'lay o hien hanh
    Else ' neu co nhung o lien quan trong cell
        Set pre_rng = Union(Target.Precedents, Target)
    End If
End Sub

 

[Excel365]

Dạ, e cám ơn Thầy, e chưa đúng ý tác giả !

To huuduy.duy:

E xin phép mượn code của a OverAc để chỉnh sửa . Bạn coi thử được chưa nha bạn !

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static pre_rng As Range
On Error Resume Next
    pre_rng.Interior.ColorIndex = 0 'dua nhung vung luc truoc ve lai khong mau
    If Target.Count > 1 Then Exit Sub 'chi cho phep chon 1 cell
    Target.Interior.ColorIndex = 8 'to mau cho o hien hanh
    Target.Precedents.Interior.ColorIndex = 8 'to mau cho nhung o lien quan trong cong thuc
    If Target.Precedents Is Nothing Then 'neu o do khong co cong thuc toi nhung o lien quan
        Set pre_rng = Target 'lay o hien hanh
    Else ' neu co nhung o lien quan trong cell
        Set pre_rng = Union(Target.Precedents, Target)
    End If
End Sub

Cám ơn bạn nhiều, thật tuyệt vời. Chúc bạn ngày cuối tuần vui vẻ

 

[dohin1992]

Mình muốn thay vì tô màu, mà là hiện mũi tên từ vùng liên kết đến vùng hiện hành thì làm như thế nào ah

 

[Excel365]

Mình muốn thay vì tô màu, mà là hiện mũi tên từ vùng liên kết đến vùng hiện hành thì làm như thế nào ah

Bạn sử dụng chức năng có sẵn trong Excel