NADİR YILDIZ
Altın Üye
- Katılım
- 7 Ocak 2006
- Mesajlar
- 1,264
- Excel Vers. ve Dili
- 2016 Türkçe
Arkadaşlar iki listede aynı olanları renklendirip.aynı olmayanları listelemek istiyorum
Ekli dosyalar
-
2 MB Görüntüleme: 16
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
Sub test()
Dim sonE As Long, sonY As Long, i As Long, al
sonE = Cells(Rows.Count, "N").End(3).Row
sonY = Cells(Rows.Count, "Z").End(3).Row
Range("A5:L" & Rows.Count).ClearContents
With Range("N5:X" & sonE & ",Z5:AJ" & sonY)
.Font.ColorIndex = xlAutomatic
.Font.Bold = False
.Interior.ColorIndex = xlAutomatic
End With
With CreateObject("Scripting.Dictionary")
For i = 5 To sonY
al = Join(Application.Index(Cells(i, "Z").Resize(, 11).Value, 0), "|")
.Add al, i
Next i
For i = 5 To sonE
al = Join(Application.Index(Cells(i, "N").Resize(, 11).Value, 0), "|")
If .exists(al) Then
With Union(Cells(.Item(al), "Z").Resize(, 11), Cells(i, "N").Resize(, 11))
.Font.Color = vbRed
.Font.Bold = True
.Interior.Color = vbYellow
End With
.Remove al
End If
Next i
If .Count > 0 Then
i = 5
For Each al In .items
Cells(al, "Z").Resize(, 11).Copy Cells(i, "A")
i = i + 1
Next
End If
End With
End Sub
Private Sub CommandButton1_Click()
Dim sonE As Long, sonY As Long, i As Long, al
sonE = Cells(Rows.Count, "N").End(3).Row
sonY = Cells(Rows.Count, "Z").End(3).Row
Range("A5:L" & Rows.Count).ClearContents
With Range("N5:X" & sonE & ",Z5:AJ" & sonY)
.Font.ColorIndex = xlAutomatic
.Font.Bold = False
.Interior.ColorIndex = xlAutomatic
End With
With CreateObject("Scripting.Dictionary")
For i = 5 To sonY
al = Join(Application.Index(Cells(i, "Z").Resize(, 11).Value, 0), "|")
If Not .exists(al) Then
.Add al, i
End If
Next i
For i = 5 To sonE
al = Join(Application.Index(Cells(i, "N").Resize(, 11).Value, 0), "|")
If .exists(al) Then
With Union(Cells(.Item(al), "Z").Resize(, 11), Cells(i, "N").Resize(, 11))
.Font.Color = vbRed
.Font.Bold = True
.Interior.Color = vbYellow
End With
.Remove al
End If
Next i
If .Count > 0 Then
i = 5
For Each al In .items
Cells(al, "Z").Resize(, 11).Copy Cells(i, "A")
i = i + 1
Next
End If
End With
End Sub