Soru listede benzer olmayanları aktarma

[NADİR YILDIZ]

Arkadaşlar iki listede aynı olanları renklendirip.aynı olmayanları listelemek istiyorum

 

[NADİR YILDIZ]

arkadaşlar çözüm önerisi olan varmı

 

[veyselemre]

Sorunuzun bu şekliyle çalışır, tekrar eden yeni veya eski fatura varsa yanlış sonuç verecektir. Benden bu kadar.

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

 

[NADİR YILDIZ]

Sayın veysel bey
gerçekten güzel olmuş.yardımınız için teşekkür ederim.
yeni listeye haftalık olarak ekleme yapıyorum.eski listede ve yeni listede benzer ft oluyor.onları birbirinden ayırıp yeni bir liste yapmak istiyorum.
aynı ft lar olmadığında gayet güzel aktarıyor.ancak benzer ft lar olunca sorun çıkıyor.

nasıl çözeriz.

iyi çalışmalar

 

[NADİR YILDIZ]

arkadaşlar günaydın bu konuda yardım edebilecekmisiniz ?

 

[NADİR YILDIZ]

arkadaşlar daha önce burada başka bir çalışmam için yardımcı olmuşlardı.o kodları bu dosyay uyguladım ama sonuç alamadım

 

[Erdem Akdemir]

Nadir bey merhaba,

Size alternatif bir dosya hazırladım.
Bu mantık ile gitmeniz kodlama ve raporlamada daha rahat çalışılmasını sağlayacaktır.

 

[NADİR YILDIZ]

SAYIN erdem öncelikle çözüm öneriniz için teşekkür ediyorum.

sizin gönderdiğiniz örnekte gayet güzel bir çözüm
ancak benim örnek dosyamda birçok sekme var yeni faturaları bu sekmelere makro ile aktarıp kontrol tablosu oluşturmak istiyorum.
sizin gönderdiğiniz dosya hem fazladan sekme hemde eski yeni faturaları süz aktar gibi ilaveler çıkacak.bu dosyayı benim dışımda başkalarıda kullanacak çok sekme olunca hata yapma olasılığı artacak bu sebeple ekte örnek dosya ekliyorum.bunun üzerinden çalışma yapabilirsek çok daha verimli ve pratik olacak.sorumda ilk gönderdiğim dosyayı ekliyorum.bunun için çözüm üretebilirsek memnun olacağım.daha sonra gönderdiğim örnek dosyalar üzerinden çözüm üretebilirmiyiz. diye örnek dosya eklemiştim.benim ilk gönderdiğim dosya üzerinden çalışma yaparsak.aşağıda ekteki dosyam sorunum çözülmüş olacak.buradaki mantık eski ft listesi ve yeni ft listesi karşılaştırıp aynı olanları sarı kırmızıya boyamak aynı olmayan ft renklendirmeyerek işlenmemiş ft listesine aktarması.bu listeyi ben daha sonra diğer sekmelere aktaracağım.

iyi çalışmalar

 

[Erdem Akdemir]

Ben alternatif bir çözüm sunmak istedim. İsterseniz sadece işlenmeyen kayıtları da görebilirsiniz. Kodu altındaki kısmı silmeniz yeterli olur.
Size kolaylıklar dilerim.

 

[NADİR YILDIZ]

ilginize teşekkür ederim.
dosyam üzerinden çözüm alabilirsem daha memnun olacağım

iyi çalışmalar

 

[NADİR YILDIZ]

arkadaşlar bu konuda yardım edecek bir üstat varmı acaba ?
değişik çözüm önerisi olanlar oldu ancak tam olarak benim sorunuma çözüm olmadı.
benim için önemli bir konu

 

[NADİR YILDIZ]

arkadaşlar günaydın
bu sorumla ilgili birçok kez yazdım ancak istediğim sonucu maalesef alamadım.
bugüne kadar soru sorup cevap alamadığım olmadı.herkese ayrı ayrı teşekkür ederim.
ancak bu sorunun çözümüyle ilgili cevap veren arkadaşlar olmasına rağmen benim istediğim gibi bir sonuç alamadım.
benim için önemli bir konu ve aciliyeti var.
zor ve uğraştırıcı zaman alıcı bir çalışma diyorsanız.
bu konuda yardımcı olacak arkadaşlarlada görüşmek isterim.
buradaki üstatlardan bu konuda yardım etmelerini rica ediyorum.

 

[Ömer]

Merhaba,

Yapmak istediğiniz;
" İŞLENEN FATURA" fatura sayfasındaki Yeni faturalar ile Eski faturalar bölümünü karşılaştırıp benzer olmayanları İşlenmemiş faturalar bölümüne aktarmak mı?

 

[NADİR YILDIZ]

Merhaba

evet Ömer bey
veysel bey buraya kadar olan kısmı yaptı.ancak eski listede aynı fatura numarası olanlar faturalar olunca sorun çıkıyor.
burayı nasıl çözebiliriz ömer bey.bu dosyam üzerinde çalışma yaparsanız memnun olurum

 

[Ömer]

Detaylı incelemedim.
Veysel Bey'in kodlarını bu şekilde kullanırsanız istediğiniz sonucu veriyor mu?

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

 

[NADİR YILDIZ]

Ömer bey çok teşekkür ederim
sonunda sorunumu çözdünüz

iyi çalışmalar