Tarih formatına göre mükerrer kayıtları aktarma ve renklendirme

[ASLAN7410]

Merhaba, alternatif olsun.
.

Sayın Ömer Bey öncelikle ilgilendiğiniz için çok teşekkür ederim, sizin kodlar gönderdiğiniz örnek sayfa üzerinde güzel çalışıyor,
ancak sayfanın alt kısmına bilgi eklediğimde, renklendirme de hata oluyor, ayrıca kendi sayfamdaki bilgileri sizin hazırlamış olduğunuz sayfaya eklediğimde aynı sorunu verdi.

 

[ASLAN7410]

Sayın hocalarım, yapmış olduğunuz çaba ve emeklere çok çok teşekkür ederim.

Bu örneklerle renklendirilmiş olan 22.000 satırın kontrolü arada tek kalan tarihler olduğundan çok zor oluyor ve saatlerimi alıyor.

Ekte gönderdiğim L sütunundaki aynı tarih olanları (mükerrer kayıtları) sayfa2'ye aktarıp,
burada dokuma şeklinde (bir sarı renk bir gri renk şeklinde) makro ile renklendirme yapmak istiyorum,
bu şekilde mükerrer kayıtları incelemek daha kolay olacak.

Yardım eder misiniz?

 

[ASLAN7410]

Sayın hocalarım nette ve forumda buna benzer bir uygulama bulamadım, yardımcı olur musunuz?

 

[Ziynettin]

Sayın Aslan sorunuzu doğru anlamışı mıyım.

Sub deneme()
Dim a(), b(), d As Object
Dim S1 As Worksheet, S2 As Worksheet
Dim i As Long, x As Long, Son As Long, Say As Long
Dim y As Long

Set S1 = Worksheets("Sayfa1")
Set S2 = Worksheets("Sayfa2")
Set d = CreateObject("Scripting.Dictionary")

Son = S1.Range("A" & Rows.Count).End(3).Row

a = S1.Range("A2:Q" & Son)

For i = 1 To UBound(a)
    d(a(i, 12)) = d(a(i, 12)) + 1
Next i

ReDim b(1 To UBound(a), 1 To UBound(a, 2))
For x = 1 To UBound(a)
    If d(a(x, 12)) > 1 Then
        Say = Say + 1
        For y = 1 To UBound(a, 2)
            b(Say, y) = a(x, y)
        Next y
    End If
Next x

S2.Range("A2:Q" & Rows.Count).Clear
S2.Range("A2").Resize(Say, UBound(a, 2)) = b
            
d.RemoveAll
renk = Array(6, 15, 0)
    For Each c In S2.Range("L2", S2.[L65000].End(xlUp))
        If c <> "" Then d.Item(c.Value) = d.Item(c.Value) + 1
    Next c
    For Each c In S2.Range("L2", S2.[L65000].End(xlUp))
        If c <> "" Then
            kk = (Application.Match(c.Value, d.keys, 0)) Mod UBound(renk)
            [COLOR="Red"]If d.Item(c.Value) > 1 Then c.Offset(, -11).Resize(, 17).Interior.ColorIndex = renk(kk)[/COLOR]
        End If
    Next c
    S2.Select
    MsgBox "İşlem tamam.", vbInformation
End Sub

 

[ASLAN7410]

Sayın Ziynettin Bey ilginiz için çok teşekkür ederim.

Tam istediğim gibi oldu, yalnız veriler sayfa2'ye aktarıldığında renklendirmeyi A sütunu ile Q sütunu arasını komple renklendirirse daha güzel olacak.

 

[Ziynettin]

#24 nolu mesajdaki kodu tekrar deneyin. Kırmızı yazılı satır düzenlendi.

 

[ASLAN7410]

Sayın Ziynettin gönderdiğiniz örnek içerisine kendi orijinal verilerimi yapıştırıp butona bastığımda bazı mükerrer
olmayan verileri de aktarıyor, bu işlemi parçalayarak yapmak istediğimde 200.satırdan sonrası karışıyor.
Benim verilerim ise 20.000 üzerinde.

 

[ASLAN7410]

Sayın Ziynettin sorunu çözdüm ellerinize sağlık, çok teşekkür ediyorum, Allah razı olsun.

Hayırlı geceler hayırlı çalışmalar.