Option Explicit
Sub ColorRanges()
Dim Clls As Range, sRng As Range, Rng As Range
Dim VTr As Byte, Dem As Integer
Dim Ten1 As String, Ten2 As String, MyAdd As String
Set Rng = Selection
For Each Clls In Rng
VTr = InStr(Clls.Value, Chr(10))
If VTr > 1 Then
Ten1 = Left(Clls.Value, VTr - 1)
Ten2 = Mid(Clls.Value, VTr + 1)
Set sRng = Rng.Find(Ten1, , xlFormulas, xlPart)
MyAdd = sRng.Address
Do
If InStr(sRng.Value, Ten2) > 0 And sRng.Address <> Clls.Address Then
Clls.Interior.ColorIndex = 35
sRng.Font.ColorIndex = 38
End If
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
Next Clls
End Sub
Option Explicit
Sub Ktra()
Dim tb, star As String
Dim tam As Variant, cg As Integer
Dim Rg, Cls, C As Range
On Error Resume Next
Set Rg = Application.InputBox("Dung con tro chon vung", , , , , , , 8)
Rg.ClearComments
With Application.WorksheetFunction
For Each Cls In Rg.Cells
tam = Split(Cls, Chr(10))
cg = .CountIf(Rg, Cls) + .CountIf(Rg, tam(1) & Chr(10) & tam(0))
If cg > 1 Then
Cls.AddComment
Set C = Rg.Find(Cls, LookIn:=xlValues, LookAt:=xlWhole)
If Not C Is Nothing Then
star = C.Address
Do
tb = tb & C.Address & Chr(10)
Set C = Rg.FindNext(C)
Loop While Not C Is Nothing And C.Address <> star
End If
Set C = Rg.Find(tam(1) & Chr(10) & tam(0), _
LookIn:=xlValues, LookAt:=xlWhole)
If Not C Is Nothing Then
star = C.Address
Do
tb = tb & C.Address & Chr(10)
Set C = Rg.FindNext(C)
Loop While Not C Is Nothing And C.Address <> star
End If
Cls.Comment.Text Text:="So o trung: " & Str$(cg) & Chr(10) & tb
tb = ""
End If
Next
End With
Set Rg = Nothing
Set Cls = Nothing
Set C = Nothing
End Sub
