Sub CommandButton1_Click()
Dim r As Range, a(), i As Long, j As Long, iR As Long, iC As Long, _
xI As Long, yI As Long, xJ As Long, yJ As Long
Dim co As Integer, hasDoub As Boolean
Set r = ActiveSheet.Range("a5").CurrentRegion
iR = r.Rows.Count
iC = r.Columns.Count
r.Cells.Interior.ColorIndex = 0
ReDim a(1 To iR, 1 To iC)
a = r
co = 1
For i = 1 To iR * iC - 1
hasDoub = True
xI = WorksheetFunction.RoundUp(i / iC, 0)
yI = IIf(i Mod iC = 0, iC, i Mod iC)
If a(xI, yI) <> "" Then
For j = i + 1 To iR * iC
xJ = WorksheetFunction.RoundUp(j / iC, 0)
yJ = IIf(j Mod iC = 0, iC, j Mod iC)
If a(xJ, yJ) <> "" Then
If a(xI, yI) = a(xJ, yJ) Then 'Hai thủ tục chỉ khác nhau ở phép so sánh này'
If hasDoub Then
co = co + 1
r.Cells(xI, yI).Interior.ColorIndex = co
End If
r.Cells(xJ, yJ).Interior.ColorIndex = co
hasDoub = False
a(xJ, yJ) = ""
End If
End If
Next
End If
Next
Set r = Nothing
Erase a
End SubSub CommandButton2_Click()
Dim r As Range, a(), i As Long, j As Long, iR As Long, iC As Long, _
xI As Long, yI As Long, xJ As Long, yJ As Long
Dim co As Integer, hasDoub As Boolean
Set r = ActiveSheet.Range("a5").CurrentRegion
iR = r.Rows.Count
iC = r.Columns.Count
r.Cells.Interior.ColorIndex = 0
ReDim a(1 To iR, 1 To iC)
a = r
co = 5
For i = 1 To iR * iC - 1
hasDoub = True
xI = WorksheetFunction.RoundUp(i / iC, 0)
yI = IIf(i Mod iC = 0, iC, i Mod iC)
If a(xI, yI) <> "" Then
For j = i + 1 To iR * iC
xJ = WorksheetFunction.RoundUp(j / iC, 0)
yJ = IIf(j Mod iC = 0, iC, j Mod iC)
If a(xJ, yJ) <> "" Then
If a(xI, yI) = a(xJ, yJ) Or CStr(a(xI, yI)) = StrReverse(CStr(a(xJ, yJ))) Then
If hasDoub Then
co = co + 1
r.Cells(xI, yI).Interior.ColorIndex = co
End If
r.Cells(xJ, yJ).Interior.ColorIndex = co
hasDoub = False
a(xJ, yJ) = ""
End If
End If
Next
End If
Next
Set r = Nothing
Erase a
End Sub
Sub Thuan()
Dim Rng As Range, Clls As Range, Dic As Object, OldRng As String
Dim n As Long, tmp As String
'On Error Resume Next
Set Rng = Range("A1").CurrentRegion
Rng.Interior.ColorIndex = xlNone
Set Dic = CreateObject("Scripting.Dictionary")
n = 2
For Each Clls In Rng
If Clls.Text <> "" Then
If Not Dic.Exists(Clls.Text) Then
Dic.Add Clls.Text, Clls.Address
Else
If Range(Dic.Item(Clls.Text)).Interior.ColorIndex = xlNone Then
n = n + 1
Range(Dic.Item(Clls.Text)).Interior.ColorIndex = n
End If
OldRng = Dic.Item(Clls.Text)
tmp = Dic.Item(Clls.Text) & ", " & Clls.Address
Dic.Item(Clls.Text) = tmp
Range(tmp).Interior.ColorIndex = Range(OldRng).Interior.ColorIndex
End If
End If
Next
End SubMình nghĩ có thể dùng hàm MOD để khi n >56 thì quay lại từ đầu (như vậy đơn giản hơn)
Dùng RGB có thể xác định 16.7 triệu màu, tuy nhiên Excel chỉ thể hiện 56 màu mà thôi. Tức thời có thể thấy màu RGB, nhưng sau khi save, đóng lại, mở lên chỉ còn 56 màu.
tmp = Dic.Item(Clls.Text) & ", " & Clls.AddressĐề bài của bạn và cả trong file đính kèm đều xác định các số sau: 12, 12 và 21 đều thỏa mãn tính THUẬN-ĐẢO (nghĩa là ban đầu bạn MONG MUỐN các số THUẬN và ĐẢO đều tô màu, bây giờ bạn lại cho rằng Code của chúng tôi CHƯA THỎA MÃN!!!!!
ĐẢO cũng tương tự thôi mà (lý ra bạn có thể dựa vào code THUAN để biến đổi)
Sub Dao()
Dim Rng As Range, Clls As Range, Dic As Object, OldRng As String
Dim n As Long, tmp As String
On Error Resume Next
Set Rng = Range("A1").CurrentRegion
Rng.Interior.ColorIndex = xlNone
Set Dic = CreateObject("Scripting.Dictionary")
n = 2
For Each Clls In Rng
If Clls.Text <> "" Then
If (Not Dic.Exists(Clls.Text)) And (Not Dic.Exists(StrReverse(Clls.Text))) Then
Dic.Add Clls.Text, Clls.Address
Else
If Dic.Exists(Clls.Text) Then
OldRng = Dic.Item(Clls.Text)
Else
OldRng = Dic.Item(StrReverse(Clls.Text))
End If
If Range(OldRng).Interior.ColorIndex = xlNone Then
n = n + 1
Range(OldRng).Interior.ColorIndex = n
End If
tmp = OldRng & ", " & Clls.Address
If Dic.Exists(Clls.Text) Then
Dic.Item(Clls.Text) = tmp
Else
Dic.Item(StrReverse(Clls.Text)) = tmp
End If
Range(tmp).Interior.ColorIndex = Range(OldRng).Interior.ColorIndex
End If
End If
Next
End Sub
