• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Veri Karşılaştırma.

C

ccuneyt13

Altın Üye
Katılım
20 Ocak 2011
Mesajlar
478
Excel Vers. ve Dili
Office 365 Türkçe (64 bit)
Merhaba,

Her hafta düzenli olarak aldığım bir raporun 1 önceki haftada aldığım raporla karşılaştırmasını yapmak istiyorum.
Bu karşılaştırma için kriterler İşletme (A sütünu) - Abone No (B sütünu) - Dönem (C sütünu) aynı olan veya olmayan şeklinde olmalı.
(Diğer sütünlardaki değerlerde değişik olsa bile ödenip ödenmediğini göstermiyor.)
Bu kritere göre GEÇEN HAFTA ki listede olup BU HAFTAdaki listede olmayanları ÖDENEN sekmesine,
BU HAFTAKİ listede olupta GEÇEN HAFTA ki listede olmayanları YENİ sekmesine,
Hem BU HAFTA hemde GEÇEN HAFTA daki listede olanlarıda ÖDENMEYEN sekmesine, kopyalamak istiyorum.



Yardımcı olan, olamayan tüm arkadaşlara her zaman olduğu gibi şimdiden teşekkürlerimi sunarım.
 

Ekli dosyalar

yardımcı olabilecek varmı :roll:
 
kodunuz ektedir, inceleyeniz.. Saygılar..

Kod: 
Sub karşılaştır() 'CODED BY CİHANGİR...
On Error Resume Next

Set s1 = Sheets("GEÇEN HAFTA")
Set s2 = Sheets("BU HAFTA")
Set s3 = Sheets("ÖDENEN")
Set s4 = Sheets("ÖDENMEYEN")
Set s5 = Sheets("YENİ")

s3.Range("A2:DM65536").ClearContents
s4.Range("A2:DM65536").ClearContents
s5.Range("A2:DM65536").ClearContents

sat1 = s1.[A65536].End(3).Row
sat2 = s2.[A65536].End(3).Row
sat3 = s3.[A65536].End(3).Row + 1
sat4 = s4.[A65536].End(3).Row + 1
sat5 = s5.[A65536].End(3).Row + 1

Application.ScreenUpdating = False

For i = 2 To sat1

        If s1.Cells(i, 1).Value = s2.Cells(i, 1).Value And _
           s1.Cells(i, 2).Value = s2.Cells(i, 2).Value And _
           s1.Cells(i, 5).Value = s2.Cells(i, 5).Value Then
        
         s4.Cells(sat4, 1).Value = s1.Cells(i, 1).Value ' ödenmeyen
         s4.Cells(sat4, 2).Value = s1.Cells(i, 2).Value
         s4.Cells(sat4, 3).Value = s1.Cells(i, 3).Value
         s4.Cells(sat4, 4).Value = s1.Cells(i, 4).Value
         s4.Cells(sat4, 5).Value = s1.Cells(i, 5).Value
         s4.Cells(sat4, 6).Value = s1.Cells(i, 6).Value
         s4.Cells(sat4, 7).Value = s1.Cells(i, 7).Value
         s4.Cells(sat4, 8).Value = s1.Cells(i, 8).Value
         s4.Cells(sat4, 9).Value = s1.Cells(i, 9).Value
         s4.Cells(sat4, 10).Value = s1.Cells(i, 10).Value
         s4.Cells(sat4, 11).Value = s1.Cells(i, 11).Value
         s4.Cells(sat4, 12).Value = s1.Cells(i, 12).Value
         s4.Cells(sat4, 13).Value = s1.Cells(i, 13).Value
         s4.Cells(sat4, 14).Value = s1.Cells(i, 14).Value
         s4.Cells(sat4, 15).Value = s1.Cells(i, 15).Value
         s4.Cells(sat4, 16).Value = s1.Cells(i, 16).Value
         s4.Cells(sat4, 17).Value = s1.Cells(i, 17).Value
            
            sat4 = sat4 + 1
        
        End If
        
            
        If s1.Cells(i, 1).Value <> s2.Cells(i, 1).Value And _
           s1.Cells(i, 2).Value <> s2.Cells(i, 2).Value And _
           s1.Cells(i, 5).Value <> s2.Cells(i, 5).Value Then
        
     

         s3.Cells(sat3, 1).Value = s1.Cells(i, 1).Value ' ödenen
         s3.Cells(sat3, 2).Value = s1.Cells(i, 2).Value
         s3.Cells(sat3, 3).Value = s1.Cells(i, 3).Value
         s3.Cells(sat3, 4).Value = s1.Cells(i, 4).Value
         s3.Cells(sat3, 5).Value = s1.Cells(i, 5).Value
         s3.Cells(sat3, 6).Value = s1.Cells(i, 6).Value
         s3.Cells(sat3, 7).Value = s1.Cells(i, 7).Value
         s3.Cells(sat3, 8).Value = s1.Cells(i, 8).Value
         s3.Cells(sat3, 9).Value = s1.Cells(i, 9).Value
         s3.Cells(sat3, 10).Value = s1.Cells(i, 10).Value
         s3.Cells(sat3, 11).Value = s1.Cells(i, 11).Value
         s3.Cells(sat3, 12).Value = s1.Cells(i, 12).Value
         s3.Cells(sat3, 13).Value = s1.Cells(i, 13).Value
         s3.Cells(sat3, 14).Value = s1.Cells(i, 14).Value
         s3.Cells(sat3, 15).Value = s1.Cells(i, 15).Value
         s3.Cells(sat3, 16).Value = s1.Cells(i, 16).Value
         s3.Cells(sat3, 17).Value = s1.Cells(i, 17).Value

            sat3 = sat3 + 1
        
    End If
        
         Next i
        
    For y = 2 To sat2

        If s2.Cells(y, 1).Value <> s1.Cells(y, 1).Value And _
           s2.Cells(y, 2).Value <> s1.Cells(y, 2).Value And _
           s2.Cells(y, 5).Value <> s1.Cells(y, 5).Value Then
        
         s5.Cells(sat5, 1).Value = s2.Cells(y, 1).Value ' yeni
         s5.Cells(sat5, 2).Value = s2.Cells(y, 2).Value
         s5.Cells(sat5, 3).Value = s2.Cells(y, 3).Value
         s5.Cells(sat5, 4).Value = s2.Cells(y, 4).Value
         s5.Cells(sat5, 5).Value = s2.Cells(y, 5).Value
         s5.Cells(sat5, 6).Value = s2.Cells(y, 6).Value
         s5.Cells(sat5, 7).Value = s2.Cells(y, 7).Value
         s5.Cells(sat5, 8).Value = s2.Cells(y, 8).Value
         s5.Cells(sat5, 9).Value = s2.Cells(y, 9).Value
         s5.Cells(sat5, 10).Value = s2.Cells(y, 10).Value
         s5.Cells(sat5, 11).Value = s2.Cells(y, 11).Value
         s5.Cells(sat5, 12).Value = s2.Cells(y, 12).Value
         s5.Cells(sat5, 13).Value = s2.Cells(y, 13).Value
         s5.Cells(sat5, 14).Value = s2.Cells(y, 14).Value
         s5.Cells(sat5, 15).Value = s2.Cells(y, 15).Value
         s5.Cells(sat5, 16).Value = s2.Cells(y, 16).Value
         s5.Cells(sat5, 17).Value = s2.Cells(y, 17).Value

            sat5 = sat5 + 1
              
             End If
        Next y
        
Msgbox " Veri karşılaştırma aktarımı tamamlanmıştır... " , , ""

Application.ScreenUpdating = True
End Sub
 
Son düzenleme:
Cihangir bey öncelikle vakit ayırdığınız için teşekkürler. Verdiğiniz kod'u uyguladım fakat bazı noksanlıklar oluştu. Örnek Dosyanın sütünlarda eksiltme yapıp açıklama ekledim yanlarına.

Mevcut kodda: hem GEÇEN HAFTA'ki hem BU HAFTA daki listede olanları ÖDENMEYEN sekmesine alması gerekirken almıyor. Diğer bir husus aynı kişinin GEÇEN HAFTA' ki listede 2011/12 borcu var iken, BU HAFTA daki listede 2012/01 dönem borcu var. Yani 2011/12 olanı ÖDENEN sekmesine 2012/01 borcunuda YENi sekmesine alması gerek.

Aslında özetle GEÇEN HAFTA ve BU HAFTA daki listede A,B,E sütünları aynı(mükerrer) olanları ÖDENMEYEN sekmesine kopyaladıkdan sonra her iki sayfadan(GEÇEN HAFTA ve BU HAFTA) da silse doğal olarak GEÇEN HAFTA'daki listede kalanlar ÖDENEN'ler BU HAFTA'daki listede kalanlarda YENİ'ler oluyor.
 

Ekli dosyalar

saat 3:26 bu saate kadar calismaniz üzerinde calistim.. Lakin şemanıza baktığımda 3 tane koşul var.. ve ÖDENMEYEN Kısmının çok zor olduğunu belirtmem gerekir.. benim size bir önerim olacak.. daha kolay ve net çözüm üretmemiz için..

size önerim şu..

en son göndermiş olduğunuz ekteki dosyanın "F" sütununa "GEÇEN HAFTA" ve "BU HAFTA" sheet'ndeki verilerin karşılığına ÖDENEN, ÖDENMEYEN ve YENİ yazın... biz sadece "F" sütununu baz alarak diğer sayfalara aktaralım.. 3 koşul ile uğraşmaktansa, tek sütunda işi bitireceksiniz..

dediğimi düşünün.. iyi sonuc alacaksınız.. iyi sabahlar diliyorum.. saygılar..
 
chngrcn' Alıntı:
saat 3:26 bu saate kadar calismaniz üzerinde calistim.. Lakin şemanıza baktığımda 3 tane koşul var.. ve ÖDENMEYEN Kısmının çok zor olduğunu belirtmem gerekir.. benim size bir önerim olacak.. daha kolay ve net çözüm üretmemiz için..

size önerim şu..

en son göndermiş olduğunuz ekteki dosyanın "F" sütununa "GEÇEN HAFTA" ve "BU HAFTA" sheet'ndeki verilerin karşılığına ÖDENEN, ÖDENMEYEN ve YENİ yazın... biz sadece "F" sütununu baz alarak diğer sayfalara aktaralım.. 3 koşul ile uğraşmaktansa, tek sütunda işi bitireceksiniz..

dediğimi düşünün.. iyi sonuc alacaksınız.. iyi sabahlar diliyorum.. saygılar..
Genişletmek için tıkla ...


Cihangir bey öncelikle hakkınızı helal edin çok zaman harcamışsınız.

Önerinize gelince ilk gönderdiğim EK' te ki F sütünü malesef mükerrerlik adına bişi ifade etmiyor. yani 100 lira borcu olan 10larca abone olabilir. 2. örnek dosyada F sütününa ben kendim yazdım ödenen ödenmeyen diye yaklaşık 5000-6000 adet satıra tek tek ödendi ödenmedi yazmam takdir edersiniz ki çok zor.

Ben sayfalara taşıma işininden vazgeçdim zor olucak o sanırım. İsteğim sadece şu GEÇEN HAFTA ve BU HAFTADA mükerrer olanları A,B,E sütünlarını baz alarak tespit edecek bi kod yeterli olucak benim için. Yani her 2 sayfada mükerrer olanları alıp başka bi sayfaya atsın ardından silsin veya nasıl diyeyim bi renge boyasın her 2 sayfadada bende diğerlerini süzüp ayrıştırayım.
 
Herkese hayırlı günler. Sanırım istediğim işlem karmaşık olduğu için sonuca ulaşamadım. Benimde aklıma şöyle bi yol geldi. Sayfa1 ile Sayfa2 de A,B,E sütünları aynı olanların renkli işaretlenmesini sağlıyabilirmiyiz? Böylelikle renge göre süzme işlemi yapıp ayrıştıra bilirim.
 
Son düzenleme:
dosyanızı tamamladım.. ektedir, inceleyiniz.. saygılar..

Kod: 
Sub birleştir() 'coded by CİHANGİR..

Dim i As Long
Dim S1 As Worksheet
Dim S2 As Worksheet

Set S1 = Sheets("GEÇEN HAFTA")
Set S2 = Sheets("BU HAFTA")

S1.Range("R2:R65536").ClearContents
S2.Range("R2:R65536").ClearContents

Application.ScreenUpdating = False

For i = 2 To S1.Cells(Rows.Count, "A").End(xlUp).Row
     a = S1.Cells(i, "A").Value
     b = S1.Cells(i, "B").Value
     d = S1.Cells(i, "D").Value
     e = S1.Cells(i, "E").Value

    S1.Cells(i, "R").Value = a & b & d & e

        Next i
        
For y = 2 To S2.Cells(Rows.Count, "A").End(xlUp).Row
     f = S2.Cells(y, "A").Value
     g = S2.Cells(y, "B").Value
     h = S2.Cells(y, "D").Value
     j = S2.Cells(y, "E").Value

    S2.Cells(y, "R").Value = f & g & h & j

        Next y
        
        MsgBox " İstediğin satırları Birleştirdim... :) ", vbInformation, "Coded by CİHANGİR.."
Application.ScreenUpdating = True
End Sub


    Sub BulRenklendir() 'coded by CİHANGİR..
 
    Dim c As Range, Adr As Variant, i As Long
    Dim S1 As Worksheet, S2 As Worksheet
    
    Set S1 = Sheets("GEÇEN HAFTA")
    Set S2 = Sheets("BU HAFTA")
 
    S1.[R:R].Interior.ColorIndex = xlNone
    S2.[R:R].Interior.ColorIndex = xlNone
 
    With S1.Range("R2:R" & S1.Cells(Rows.Count, "R").End(xlUp).Row)
      For i = 2 To S2.Cells(Rows.Count, "R").End(xlUp).Row
         Set c = .Find(S2.Cells(i, "R"), , xlValues, xlWhole)
           If Not c Is Nothing Then
             Adr = c.Address
               Do
                  S1.Cells(c.Row, "R").Interior.ColorIndex = 36
                  S2.Cells(i, "R").Interior.ColorIndex = 36
               Set c = .FindNext(c)
               Loop While Not c Is Nothing And c.Address <> Adr
           End If
        Next i
    End With
    
    Set c = Nothing
    Set S1 = Nothing: Set S2 = Nothing
 MsgBox " Renkli çamaşırlar ile Beyaz çamaşırlar ayrıştırıldı... :) ", vbInformation, "Coded by CİHANGİR.."
 
End Sub


Sub renklileri_yıka() 'coded by CİHANGİR..

Dim i As Long
Dim S1 As Worksheet
Dim S2 As Worksheet
Dim S3 As Worksheet
Dim S4 As Worksheet
Dim S5 As Worksheet

Set S1 = Sheets("GEÇEN HAFTA")
Set S2 = Sheets("BU HAFTA")
Set S3 = Sheets("ÖDENEN")
Set S4 = Sheets("ÖDENMEYEN")
Set S5 = Sheets("YENİ")

S3.Range("A2:DM65536").ClearContents
S4.Range("A2:DM65536").ClearContents
S5.Range("A2:DM65536").ClearContents

sat1 = S1.[A65536].End(3).Row ' geçen hafta
sat2 = S2.[A65536].End(3).Row ' bu hafta
sat3 = S3.[A65536].End(3).Row + 1 ' ödenen
sat4 = S4.[A65536].End(3).Row + 1 'ödenmeyen
sat5 = S5.[A65536].End(3).Row + 1 ' yeni

Application.ScreenUpdating = False

For i = 2 To S1.[A65536].End(3).Row

    If S1.Cells(i, "R").Interior.ColorIndex = 36 Then
        
         S4.Cells(sat4, 1).Value = S1.Cells(i, 1).Value ' ödenmeyen
         S4.Cells(sat4, 2).Value = S1.Cells(i, 2).Value
         S4.Cells(sat4, 3).Value = S1.Cells(i, 3).Value
         S4.Cells(sat4, 4).Value = S1.Cells(i, 4).Value
         S4.Cells(sat4, 5).Value = S1.Cells(i, 5).Value
         S4.Cells(sat4, 6).Value = S1.Cells(i, 6).Value
         S4.Cells(sat4, 7).Value = S1.Cells(i, 7).Value
         S4.Cells(sat4, 8).Value = S1.Cells(i, 8).Value
         S4.Cells(sat4, 9).Value = S1.Cells(i, 9).Value
         S4.Cells(sat4, 10).Value = S1.Cells(i, 10).Value
         S4.Cells(sat4, 11).Value = S1.Cells(i, 11).Value
         S4.Cells(sat4, 12).Value = S1.Cells(i, 12).Value
         S4.Cells(sat4, 13).Value = S1.Cells(i, 13).Value
         S4.Cells(sat4, 14).Value = S1.Cells(i, 14).Value
         S4.Cells(sat4, 15).Value = S1.Cells(i, 15).Value
         S4.Cells(sat4, 16).Value = S1.Cells(i, 16).Value
         S4.Cells(sat4, 17).Value = S1.Cells(i, 17).Value
            
            sat4 = sat4 + 1
            
     Else
     
         S3.Cells(sat3, 1).Value = S1.Cells(i, 1).Value ' ödenen
         S3.Cells(sat3, 2).Value = S1.Cells(i, 2).Value
         S3.Cells(sat3, 3).Value = S1.Cells(i, 3).Value
         S3.Cells(sat3, 4).Value = S1.Cells(i, 4).Value
         S3.Cells(sat3, 5).Value = S1.Cells(i, 5).Value
         S3.Cells(sat3, 6).Value = S1.Cells(i, 6).Value
         S3.Cells(sat3, 7).Value = S1.Cells(i, 7).Value
         S3.Cells(sat3, 8).Value = S1.Cells(i, 8).Value
         S3.Cells(sat3, 9).Value = S1.Cells(i, 9).Value
         S3.Cells(sat3, 10).Value = S1.Cells(i, 10).Value
         S3.Cells(sat3, 11).Value = S1.Cells(i, 11).Value
         S3.Cells(sat3, 12).Value = S1.Cells(i, 12).Value
         S3.Cells(sat3, 13).Value = S1.Cells(i, 13).Value
         S3.Cells(sat3, 14).Value = S1.Cells(i, 14).Value
         S3.Cells(sat3, 15).Value = S1.Cells(i, 15).Value
         S3.Cells(sat3, 16).Value = S1.Cells(i, 16).Value
         S3.Cells(sat3, 17).Value = S1.Cells(i, 17).Value
         
            sat3 = sat3 + 1


    End If
    
    Next i


For y = 2 To S2.[A65536].End(3).Row

    If S2.Cells(y, "R").Interior.ColorIndex <> 36 Then
        
         S5.Cells(sat5, 1).Value = S2.Cells(y, 1).Value ' yeni
         S5.Cells(sat5, 2).Value = S2.Cells(y, 2).Value
         S5.Cells(sat5, 3).Value = S2.Cells(y, 3).Value
         S5.Cells(sat5, 4).Value = S2.Cells(y, 4).Value
         S5.Cells(sat5, 5).Value = S2.Cells(y, 5).Value
         S5.Cells(sat5, 6).Value = S2.Cells(y, 6).Value
         S5.Cells(sat5, 7).Value = S2.Cells(y, 7).Value
         S5.Cells(sat5, 8).Value = S2.Cells(y, 8).Value
         S5.Cells(sat5, 9).Value = S2.Cells(y, 9).Value
         S5.Cells(sat5, 10).Value = S2.Cells(y, 10).Value
         S5.Cells(sat5, 11).Value = S2.Cells(y, 11).Value
         S5.Cells(sat5, 12).Value = S2.Cells(y, 12).Value
         S5.Cells(sat5, 13).Value = S2.Cells(y, 13).Value
         S5.Cells(sat5, 14).Value = S2.Cells(y, 14).Value
         S5.Cells(sat5, 15).Value = S2.Cells(y, 15).Value
         S5.Cells(sat5, 16).Value = S2.Cells(y, 16).Value
         S5.Cells(sat5, 17).Value = S2.Cells(y, 17).Value
            
            sat5 = sat5 + 1
    
    End If

Next y

MsgBox " Renkliler yıkanarak kurutmaya alındı..  :) Sağlıcakla Kullanın.. ", vbInformation, "Coded by CİHANGİR.."
Application.ScreenUpdating = True

End Sub
 

Ekli dosyalar

Son düzenleme:
chngrcn' Alıntı:
dosyanızı tamamladım.. ektedir, inceleyiniz.. saygılar..
Genişletmek için tıkla ...



Cihangir bey konuyu açtığım günden bu zamana kadar göstermiş olduğunuz ilgi alaka ve harcadığınız zamana ve emeğe ne kadar teşekkür etsem azdır. Allah razı olsun sıkıntımızı giderdiniz Allahta sizin sıkıntınızı gidersin.

Tekrar çok teşekkür ederim. Saygılarımla.
 
Cümlemizden razı olsun.. Rica ederim, benim için zevkti.. İyi çalışmalar, iyi günlerde kullanın..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst