Dịch chuyển màu bằng cách click chuột lên 2 ô liền kề?

[Pozsi]

Xin chào các bác. Em có một đề tài không biết phải giải quyết làm sao?
Mong các bác chiếu cố xem xét với. Cụ thể là viết code thế nào để khi click chuột lên 2 ô liên tục trong một vùng (theo hướng từ trên xuống) thì màu sắc trong vùng đó cũng tự dịch chuyển từ trên xuống 1 vòng trong vùng đó, và lệch 3 vị trí. Không phụ thuộc vào bước màu, chỉ phụ thuộc vào vị trí màu trong vùng đó mà thôi.
Các bác xem file và giúp em với.
Thân.

 

[huuthang_bd]

Xin chào các bác. Em có một đề tài không biết phải giải quyết làm sao?
Mong các bác chiếu cố xem xét với. Cụ thể là viết code thế nào để khi click chuột lên 2 ô liên tục trong một vùng (theo hướng từ trên xuống) thì màu sắc trong vùng đó cũng tự dịch chuyển từ trên xuống 1 vòng trong vùng đó, và lệch 3 vị trí. Không phụ thuộc vào bước màu, chỉ phụ thuộc vào vị trí màu trong vùng đó mà thôi.
Các bác xem file và giúp em với.
Thân.

Hỏi lại một chút. Bạn click chọn ô C5 rồi sau đó click chọn ô C6 hay là bôi đen vùng C5:C6

 

[Pozsi]

Bôi đen vùng [C5:C6] bạn à!

 

[ndu96081631]

Thuật toán của bài toán này là QUAY CÁC ITEM TRONG 1 ARRAY
Xem code này:

Private Dic
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect(Range("C3:C11"), Target) Is Nothing Then
    If Target.Rows.Count = 2 Then Call RotatingColor
  End If
End Sub

Private Sub RotatingColor()
  Dim Clls As Range, i As Long
  Set Dic = CreateObject("Scripting.Dictionary")
  If Dic.Count = 0 Then
    For Each Clls In Range("C3:C11")
      i = i + 1
      Dic.Add i, Clls.Interior.ColorIndex
    Next
  End If
  i = 0
  For Each Clls In Range("C3:C11")
    i = i + 1
    Clls.Interior.ColorIndex = Dic.Item(((i + 5) Mod Dic.Count) + 1)
  Next
End Sub

Tôi thêm điều kiện If Dic.Count = 0 với mục đích vòng lập trong đó chỉ chạy lần đầu ---> Kể từ lần sau thì bỏ qua ---> Tiết kiệm số lần lập
Test thử xem ---> Tôi nghĩ code có thể rút gọn thêm

 

[Pozsi]

Cảm ơn bác. Còn ĐK 1 hướng thôi thì sao? Ý nghĩa của việc tạo hướng là dùng để dịch chuyển theo hướng muốn kéo về. Và em nghĩ cái khó cũng nằm ở đó luôn. Vì trong Excel nó ko phân biệt được ô click trước, ô click sau trong cùng 1 lần rê chuột.
Èo.. èo.. <Đau đầu quá!>

 

[ndu96081631]

Cảm ơn bác. Còn ĐK 1 hướng thôi thì sao? Ý nghĩa của việc tạo hướng là dùng để dịch chuyển theo hướng muốn kéo về. Và em nghĩ cái khó cũng nằm ở đó luôn. Vì trong Excel nó ko phân biệt được ô click trước, ô click sau trong cùng 1 lần rê chuột.
Èo.. èo.. <Đau đầu quá!>

Sau bạn không tạo 2 nút để chạy code ---> Lằng nhằng chi mấy cái "hướng chuột" cho rối
Code trên có sai lầm ---> Có lẽ không cần If Dic.Count = 0 Then
Chỉ vầy là đủ:

Private Sub RotatingColor()
  Dim Clls As Range, i As Long, Dic
  Set Dic = CreateObject("Scripting.Dictionary")
  For Each Clls In Range("C3:C11")
    i = i + 1
    Dic.Add i, Clls.Interior.ColorIndex
  Next
  i = 0
  For Each Clls In Range("C3:C11")
    i = i + 1
    Clls.Interior.ColorIndex = Dic.Item(((i + 5) Mod Dic.Count) + 1)
  Next
End Sub

 

[huuthang_bd]

Xin chào các bác. Em có một đề tài không biết phải giải quyết làm sao?
Mong các bác chiếu cố xem xét với. Cụ thể là viết code thế nào để khi click chuột lên 2 ô liên tục trong một vùng (theo hướng từ trên xuống) thì màu sắc trong vùng đó cũng tự dịch chuyển từ trên xuống 1 vòng trong vùng đó, và lệch 3 vị trí. Không phụ thuộc vào bước màu, chỉ phụ thuộc vào vị trí màu trong vùng đó mà thôi.
Các bác xem file và giúp em với.
Thân.

Thử xem nhé

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Dim ColorArray(9)
If Target.Areas.Count = 1 And Union(Target, [C3:C11]).Address = "$C$3:$C$11" And Target.Cells.Count = 2 And Target.Cells(1, 1).Address = ActiveCell.Address Then
    For i = 0 To 8
    ColorArray(i) = [C3:C11].Cells(i + 1, 1).Interior.Color
    Next
    For j = 0 To 8
    [C3:C11].Cells((3 + j) Mod 9 + 1, 1).Interior.Color = ColorArray(j)
    Next
End If
End Sub

 

[ndu96081631]

Cảm ơn bác. Còn ĐK 1 hướng thôi thì sao? Ý nghĩa của việc tạo hướng là dùng để dịch chuyển theo hướng muốn kéo về. Và em nghĩ cái khó cũng nằm ở đó luôn. Vì trong Excel nó ko phân biệt được ô click trước, ô click sau trong cùng 1 lần rê chuột.
Èo.. èo.. <Đau đầu quá!>

Đúng là yêu cầu tưởng chừng vô lý nhưng vẫn có thể làm được ---> Thuật toán dựa vào ActiveCell
- Khi bạn kéo chuột từ trên xuống thì Cell đầu tiên trùng với ActiveCell
- Khi bạn kéo chuột từ dưới lên thì Cell cuối cùng trùng với ActiveCell
Dựa vào sự phân biệt này, tôi xây dựng code như sau:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect(Range("C3:C11"), Target) Is Nothing Then
    If Target.Rows.Count = 2 And Target.Columns.Count = 1 Then
      If Target.Row = ActiveCell.Row Then
        Call RotatingColor([C3:C11], 3, True)
      Else
        Call RotatingColor([C3:C11], 3, False)
      End If
    End If
  End If
End Sub

Private Sub RotatingColor(Rng As Range, Step As Byte, Direct As Boolean)
  Dim Clls As Range, i As Long, Dic, Pos As Long
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To Rng.Rows.Count
    Dic.Add i, Rng.Resize(, 1)(i).Interior.ColorIndex
  Next
  For i = 1 To Rng.Rows.Count
    Pos = ((i + Rng.Rows.Count + Step * (Direct * 2 + 1) - 1) Mod Rng.Rows.Count) + 1
    Rng(i).Interior.ColorIndex = Dic.Item(Pos)
  Next
End Sub

- Màu sắc sẽ dịch chuyển theo hướng mà bạn kéo chuột
- Bước nhảy của màu có thể tùy biến thoải mái, ví dụ:
Call RotatingColor([C3:C11], 3, True) ---> Số 3 là bước nhảy = 3
Thử file xem ---> Thú vị chứ

 

[Pozsi]

Vâng! Em hiểu rồi, cảm ơn bác.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Range("C3:C11"), Target) Is Nothing And Target.Rows.Count = 2 And Target.Columns.Count = 1 Then
Call RotatingColor([C3:C11], 3, (Target.Row = ActiveCell.Row))
End If
End Sub

 

[ndu96081631]

Chính sửa lại 1 tí cho code hoàn hảo hơn:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  With Range("C3:C11")
    If Not Intersect(.Cells, Target) Is Nothing And Target.Count = 2 Then
      If Intersect(.Cells, Target).Address = Target.Address Then
        RotatingColor .Cells, 3, Target(1, 1).Address = ActiveCell.Address
      End If
    End If
  End With
End Sub

Private Sub RotatingColor(Rng As Range, Step As Byte, Direct As Boolean)
  Dim i As Long, Pos As Long, Dic
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To Rng.Rows.Count
    Dic.Add i, Rng(i, 1).Interior.ColorIndex
  Next i
  For i = 1 To Rng.Rows.Count
    Pos = ((i + Rng.Rows.Count + Step * Sgn(Direct + 0.5) - 1) Mod Rng.Rows.Count) + 1
    Rng(i, 1).Interior.ColorIndex = Dic.Item(Pos)
  Next
End Sub