snasui.com ยินดีต้อนรับ ยินดีต้อนรับสู่กระดานถามตอบ Excel and VBA และอื่น ๆ ที่เป็นมิตรกับทุกท่าน มีไฟล์แนบมหาศาล ช่วยให้ท่านค้นหาและติดตามศึกษาได้โดยง่าย สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ ระบุ Version ของ Excel
Sub Highlight_Duplicate_Entry()
Dim ws As Worksheet
Dim cell As Range
Dim myrng As Range
Dim clr As Long
Dim dict As Object
Dim colorIndex As Long
Dim cellRange As Variant
Dim rng As Variant
Dim fullRange As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
' Define the ranges
cellRange = Array("A2:A29", "D2:D29", "G2:G29", "J2:J29", "M2:M29", "P2:P29", _
"A30:A59", "D30:D59", "G30:G59", "J30:J59", "M30:M59", "P30:P59")
' Combine all ranges into one
For Each rng In cellRange
If fullRange Is Nothing Then
Set fullRange = ws.Range(rng)
Else
Set fullRange = Union(fullRange, ws.Range(rng))
End If
Next rng
Set dict = CreateObject("Scripting.Dictionary")
colorIndex = 3 ' Start coloring from color index 3
' Clear existing colors
fullRange.Interior.ColorIndex = xlNone
' Loop through each cell in the combined range
For Each cell In fullRange
If cell.Value > 0 Then ' Only consider positive values
If Application.WorksheetFunction.CountIf(fullRange, cell.Value) > 1 Then
If Not dict.exists(cell.Value) Then
dict.Add cell.Value, colorIndex
colorIndex = colorIndex + 1
End If
cell.Interior.ColorIndex = dict(cell.Value)
End If
End If
Next cell
End Sub
You do not have the required permissions to view the files attached to this post.
Sub Test0()
Dim rall As Range, r As Range, strVal As String
Dim d As Object, x As Long
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
x = 100000
With Worksheets(1)
Set rall = .Range("a2:q30,a32:q59")
rall.Interior.Color = xlNone
For Each r In rall
If Not IsEmpty(r.Value) Then
strVal = Sort0(r.Value)
If Not d.Exists(strVal) Then
d.Add key:=strVal, Item:=x
r.Interior.Color = x
x = x + 20000
Else
r.Interior.Color = d.Item(strVal)
End If
End If
Next r
End With
Application.ScreenUpdating = True
End Sub
Function Sort0(v As Long) As String
Dim i As Integer, j As Integer, k As Integer
Dim n As Integer, l As Integer, m As Integer
Dim arr() As Variant, tmp As Variant
For i = 1 To VBA.Len(v)
n = VBA.Mid(v, i, 1)
ReDim Preserve arr(m)
arr(m) = CInt(n)
m = m + 1
Next i
For k = LBound(arr) To UBound(arr)
For l = LBound(arr) To UBound(arr) - 1
If arr(l) > arr(k) Then
tmp = arr(k)
arr(k) = arr(l)
arr(l) = tmp
End If
Next l
Next k
Sort0 = VBA.Join(arr, "")
End Function
Function Sort0(v As Variant) As String
Dim i As Integer, j As Integer
Dim arr() As String, tmp As String
Dim n As Integer
v = CStr(v)
n = Len(v)
ReDim arr(1 To n)
For i = 1 To n
arr(i) = Mid(v, i, 1)
Next i
For i = 1 To n - 1
For j = i + 1 To n
If arr(i) > arr(j) Then
tmp = arr(i)
arr(i) = arr(j)
arr(j) = tmp
End If
Next j
Next i
Sort0 = Join(arr, "")
End Function
You do not have the required permissions to view the files attached to this post.
Sub Test0()
Dim rall As Range, r As Range, strVal As String
Dim d As Object, x As Long
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
x = 100000
With Worksheets(1)
Set rall = .Range("E2:E1000,H2:H1000,K2:K1000,N2:N1000,Q2:Q1000,T2:T1000,W2:W1000,Z2:Z1000,AC2:AC1000,")
rall.Interior.Color = xlNone
For Each r In rall
If Not IsEmpty(r.Value) Then
strVal = Sort0(Format(r.Value, "000"))
If Not d.Exists(strVal) Then
d.Add key:=strVal, Item:=x
r.Interior.Color = x
x = x + 20000
Else
r.Interior.Color = d.Item(strVal)
End If
End If
Next r
End With
Application.ScreenUpdating = True
End Sub
Function Sort0(v As String) As String
Dim arr() As String
Dim i As Integer, j As Integer
Dim tmp As String
ReDim arr(Len(v) - 1)
For i = 1 To Len(v)
arr(i - 1) = Mid(v, i, 1)
Next i
' Sort the array of characters
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If arr(i) > arr(j) Then
tmp = arr(i)
arr(i) = arr(j)
arr(j) = tmp
End If
Next j
Next i
Sort0 = Join(arr, "")
End Function
Sub Test0()
Dim rall As Range, r As Range, strVal As String
Dim d As Object, x As Long, itm As Variant, stra As String
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
x = 100000
With Worksheets(1)
Set rall = .Range("E2:E1000,H2:H1000,K2:K1000,N2:N1000,Q2:Q1000,T2:T1000,W2:W1000,Z2:Z1000,AC2:AC1000,")
rall.Interior.Color = xlNone
For Each r In rall
If Not IsEmpty(r.Value) Then
strVal = Sort0(Format(r.Value, "000"))
If Not d.Exists(strVal) Then
d.Add Key:=strVal, Item:=x & "|" & r.Address
r.Interior.Color = x
x = x + 20000
Else
r.Interior.Color = VBA.Split(d.Item(strVal), "|")(0)
d.Item(strVal) = r.Interior.Color & "|" & ""
End If
End If
Next r
For Each itm In d.Keys
stra = VBA.Split(d.Item(itm), "|")(1)
If stra <> "" Then
.Range(stra).Interior.Color = xlNone
End If
Next itm
End With
Application.ScreenUpdating = True
End Sub
snasui.com ยินดีต้อนรับ 
สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ 
โปรดทราบ 
