Tô màu những ô trùng liền nhau (2 người xem)

[toandiennuoc123]

Chào các bạn ! mình muốn tô màu những ô trùng liền nhau và khác màu, mong các bạn giúp đỡ, cám ơn các bạn.

 

[kuldokk]

Chào các bạn ! mình muốn tô màu những ô trùng liền nhau và khác màu, mong các bạn giúp đỡ, cám ơn các bạn.

Bác thử code này, viết dựa trên file excel của bác.

' ################################
'   Date: 10/12/2014
'   DT Nguyen: http://youtube.com/user/ductnguy
' ################################
Sub test()
Dim rng() As Variant
Dim i As Long, j As Long, seqLength As Long, c As Long, startIndex As Long
Dim arr1 As Variant

Application.ScreenUpdating = False

rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
Range("A:A").ClearFormats
ReDim arr1(1 To UBound(rng, 1), 1 To 4)
c = 0

arr1(1, 1) = False
arr1(UBound(rng, 1), 2) = False

For i = LBound(rng, 1) To UBound(rng, 1) - 1
        arr1(i + 1, 1) = (rng(i, 1) = rng(i + 1, 1))
        arr1(i, 2) = (rng(i, 1) = rng(i + 1, 1))
        arr1(i, 3) = (arr1(i, 1) = arr1(i, 2))
Next i

arr1(UBound(rng, 1), 3) = arr1(UBound(rng, 1), 1) = arr1(UBound(rng, 1), 2)

For j = LBound(arr1, 1) To UBound(arr1, 1)
    If Not arr1(j, 3) Then
        c = c + 1
        If c Mod 2 = 1 Then
            startIndex = j
        Else
            seqLength = j - startIndex + 1
            
            With Range("A" & startIndex).Resize(seqLength, 1).Interior
                .ColorIndex = 3
                .TintAndShade = -seqLength * 0.1 + 1
            End With
            
        End If
    End If
Next j
Application.ScreenUpdating = True
End Sub

 

[toandiennuoc123]

Bác thử code này, viết dựa trên file excel của bác.

Cám ơn bạn, bạn có thể chỉnh sửa cho khác màu nhau được không ? cùng 1 màu hơi khó nhìn.

 

[gtri]

Chào các bạn ! mình muốn tô màu những ô trùng liền nhau và khác màu, mong các bạn giúp đỡ, cám ơn các bạn.

Thử cái này xem sao

Public Sub To_Mau_So_Trung()
Dim DL, r As Long

Sheet1.Range("A1:A18").ClearFormats
Set DL = Sheet1.Range("A1:A18")

For r = 2 To DL.Rows.Count
If DL(r, 1) = DL(r - 1, 1) Then
DL(r - 1, 1).Interior.ColorIndex = DL(r - 1, 1) + 6
DL(r, 1).Interior.ColorIndex = DL(r, 1) + 6
End If
Next r

End Sub

 

[toandiennuoc123]

OK, tôi làm = CF được rồi. Cám ơn bạn nhiều nhé

 

[Quang_Hải]

OK, tôi làm = CF được rồi. Cám ơn bạn nhiều nhé

Thêm 1 lựa chọn khác

Sub toMau()
Dim data(), i, m1, m2, n, Mau()
Mau = Array(3, 4, 5, 6, 7, 8, 10, 12, 23, 14, 15, 16, 17, 18, 19, 20, _
22, 23, 24, 26, 27, 28, 29, 31, 32, 33, 34, 35, 36, 37, 38, 39, _
40, 41, 42, 43, 44, 45, 46, 48, 50, 52, 53, 54)
data = Range("A1", [a65536].End(3)(2)).Value
For i = 1 To UBound(data) - 1
   If data(i, 1) = data(i + 1, 1) Then
      m1 = i
      n = n + 1
      Do While data(i, 1) = data(i + 1, 1)
         m2 = i + 1
         i = i + 1
      Loop
      Range(Cells(m1, 1), Cells(m2, 1)).Interior.ColorIndex = Mau(n - 1)
      If n = UBound(Mau) Then n = 0
   End If
Next
End Sub