Sayfaları karşılaştırıp farklılıkları başka sayfaya aktarmak

unur · 31 Mart 2011

Günaydın Arkadaşlar.
Ekteki dosyada açıklama yaptım farklı iki sayfadaki bilgileri karşılaştırıp farklılıkları başka bir sayfaya aktarmak istiyorum.

Teşekkürler.

Korhan Ayhan · 31 Mart 2011

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

Uygulanan kod;

Kod:

Option Explicit
 
Sub SAYFALARI_KARŞILAŞTIR()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, S4 As Worksheet, S5 As Worksheet
    Dim X As Long, Y As Byte, Satır As Integer, Sütun As Byte, BUL As Range
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("mart")
    Set S2 = Sheets("nisan")
    Set S3 = Sheets("karşılaştırma")
    Set S4 = Sheets("gelen per.")
    Set S5 = Sheets("giden per.")
 
    S3.Range("A2:IV65536").Clear
    S4.Range("A2:IV65536").Clear
    S5.Range("A2:IV65536").Clear
 
    Satır = 2
    Sütun = S1.Range("IV1").End(1).Column
 
    For X = 2 To S1.Range("A65536").End(3).Row
        Set BUL = S2.Range("A:A").Find(S1.Cells(X, 1), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
            For Y = 2 To Sütun
                If S1.Cells(X, Y) <> S2.Cells(BUL.Row, Y) Then
                    S3.Cells(Satır, 1) = S1.Name
                    S3.Cells(Satır + 1, 1) = S2.Name
                    S3.Range("B" & Satır & ":" & Cells(Satır, Sütun + 1).Address(0, 0)).Value = S1.Range("A" & X & ":" & Cells(X, Sütun).Address(0, 0)).Value
                    S3.Range("B" & Satır + 1 & ":" & Cells(Satır + 1, Sütun + 1).Address(0, 0)).Value = S2.Range("A" & BUL.Row & ":" & Cells(BUL.Row, Sütun).Address(0, 0)).Value
                    S3.Cells(Satır, Y + 1).Interior.ColorIndex = 38
                    S3.Cells(Satır + 1, Y + 1).Interior.ColorIndex = 38
                End If
            Next
            Satır = S3.Range("A65536").End(3).Row + 2
        End If
    Next
 
    S3.Cells.EntireColumn.AutoFit
 
 
    Satır = 2
 
    For X = 2 To S2.Range("A65536").End(3).Row
        Set BUL = S1.Range("A:A").Find(S2.Cells(X, 1), LookAt:=xlWhole)
        If BUL Is Nothing Then
            S4.Range("A" & Satır & ":" & Cells(Satır, Sütun).Address(0, 0)).Value = S2.Range("A" & X & ":" & Cells(X, Sütun).Address(0, 0)).Value
            Satır = S4.Range("A65536").End(3).Row + 1
        End If
    Next
 
    S4.Cells.EntireColumn.AutoFit
 
 
    Satır = 2
 
    For X = 2 To S1.Range("A65536").End(3).Row
        Set BUL = S2.Range("A:A").Find(S1.Cells(X, 1), LookAt:=xlWhole)
        If BUL Is Nothing Then
            S5.Range("A" & Satır & ":" & Cells(Satır, Sütun).Address(0, 0)).Value = S1.Range("A" & X & ":" & Cells(X, Sütun).Address(0, 0)).Value
            Satır = S5.Range("A65536").End(3).Row + 1
        End If
    Next
 
    S5.Cells.EntireColumn.AutoFit
 
    S3.Select
 
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set S4 = Nothing
    Set S5 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

unur · 31 Mart 2011

Korhan Bey çok teşekkürler.Elinize sağlık.

Dosya işimi görüyor ancak zamanınız olursa ilave olarak, karşılaştırma sayfasına aktarma yaparken verilerinde değişiklik olmayanı almasa daha az veriyi kontrol etmiş olurum.
Teşekkürler.

Merhum İdris SERDAR · 31 Mart 2011

.

Bir de buradaki eklenti işinize yarayabilir.

http://www.excel.web.tr/f133/sayfalary-kar-yla-tyran-eklenti-t20306.html

.

unur · 31 Mart 2011

Yurttaş hocam sor göndermeden önce epey bir araştırma yaptım.Bu eklentiyide kullandım.Eklenti başka bir sayfada faklı olan verilerin adreslerini listeliyor.Korhan beyin kodları çok güzel her sayfanın verilerini alt alta vermesi dolayısıyla daha kullanışlı.

Eğer karşılaştırdığı sayfalar arasında veri değişikliği olmayan kişileri listeye almazsa bu iş çok daha kolaylaşmış olacak.

Mümkünse tabi.

Çok Teşekkürler.

Korhan Ayhan · 31 Mart 2011

Selamlar,

Sn. unur önerdiğim kod doğru çalışıyor. "karşılaştırma" isimli sayfada listelenen tüm kayıtlarda eşleşmeyen bilgiler mevcut. Bunları da zaten pembe renkle makro size gösteriyor. Siz bu işlemden farklı birşeymi istiyor sunuz?

unur · 31 Mart 2011

Korkan Bey kodlarda sıkıntı yok.Kodlar doğru çalışıyor.Ellerinize sağlık.
Eşleşmeyen bilgileri makro pembe renge boyuyor ancak hiç pembe olmayan satırlar mevcut yani birebir verileri eşleşen kişiler var. Karşılaştırma sayfasına sadece verileri eşleşmeyen kişileri alabilirmi demek istemiştim.

Teşekkürler.

Korhan Ayhan · 1 Nisan 2011

Selamlar,

Eğer eklemiş olduğum dosyadan bahsediyorsanız tekrar indirip kontrol ettim. Her satırda mutlaka pembe renkli hücreler var. Tablonuz çok sütunlu olduğu için belki gözünüzden kaçmış olabilir. Ama sağ tarafa doğru ilerlerseniz pembe renkli hücreleri göreceksiniz. Özellikle "CY" ve "DA" sütunlarında eşleşmeyen verileriniz bulunuyor.

Eğer siz kendi dosyanızda böyle bir sonuca varıyorsanız dosyanızı eklerseniz kontrol etme şansımız olur.

unur · 1 Nisan 2011

Korhan Bey çok teşekkürler. Haklısınız Sabah ilk işim tekrar kontrol etmek oldu; sonuçta ve kodlarda bir proplem yok çok güzel çalışıyor. Ellerinize sağlık.

unur · 1 Nisan 2011

Selamlar,

Korhan Beyin hazırlamış olduğu bu dosyada küçük çaplı bir kaç ekleme yapabilirmiyiz?

1-Başlık kısmını karşılaştırma yaparken karşılaştırma,gelen per. giden per. sayfalarına aynen yazdırabilirmiyiz.

İkincisi ve daha önemlisi pembe renli olan hücreleri gruplandırabilirmiyiz.Örn: tüm sayfadaki G sutununda boyalı olan kişileri alt alta, l sutunları boyalı olan kişileri alt alta şeklinde bir gruplandırma yapılabilirmi?
Teşekkürler.

Korhan Ayhan · 1 Nisan 2011

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

Uygulanan kod;

Kod:

Option Explicit
 
Sub SAYFALARI_KARŞILAŞTIR()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, S4 As Worksheet, S5 As Worksheet
    Dim X As Long, Y As Byte, Satır As Integer, Sütun As Byte, BUL As Range, Sıralanacak_Sütun As Variant
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("mart")
    Set S2 = Sheets("nisan")
    Set S3 = Sheets("karşılaştırma")
    Set S4 = Sheets("gelen per.")
    Set S5 = Sheets("giden per.")
    
    S3.Cells.Delete
    S4.Cells.Delete
    S5.Cells.Delete
    
    Satır = 2
    Sütun = S1.Range("IV1").End(1).Column
    
    S1.Rows(1).Copy S3.Range("A1")
    S1.Rows(1).Copy S4.Range("A1")
    S1.Rows(1).Copy S5.Range("A1")
    
    S3.Range("A:B").Insert
    S3.Range("A1") = "SIRA NO"
    S3.Range("B1") = "AY"
    
    S3.Rows(1).HorizontalAlignment = xlCenter
    S3.Rows(1).Font.Bold = True
    S3.Columns("A:A").HorizontalAlignment = xlCenter
    S4.Rows(1).HorizontalAlignment = xlCenter
    S4.Rows(1).Font.Bold = True
    S5.Rows(1).HorizontalAlignment = xlCenter
    S5.Rows(1).Font.Bold = True
    
    For X = 2 To S1.Range("A65536").End(3).Row
        Set BUL = S2.Range("A:A").Find(S1.Cells(X, 1), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
            For Y = 2 To Sütun
                If S1.Cells(X, Y) <> S2.Cells(BUL.Row, Y) Then
                    S3.Cells(Satır, 2) = S1.Name
                    S3.Cells(Satır + 1, 2) = S2.Name
                    S3.Range("C" & Satır & ":" & Cells(Satır, Sütun + 2).Address(0, 0)).Value = S1.Range("A" & X & ":" & Cells(X, Sütun).Address(0, 0)).Value
                    S3.Range("C" & Satır + 1 & ":" & Cells(Satır + 1, Sütun + 2).Address(0, 0)).Value = S2.Range("A" & BUL.Row & ":" & Cells(BUL.Row, Sütun).Address(0, 0)).Value
                    S3.Cells(Satır, Y + 1).Interior.ColorIndex = 38
                    S3.Cells(Satır + 1, Y + 1).Interior.ColorIndex = 38
                End If
            Next
            Satır = S3.Range("B65536").End(3).Row + 1
        End If
    Next
    
    S3.Cells.EntireColumn.AutoFit
    
    
    Sıralanacak_Sütun = InputBox("Lütfen sıralama yapmak istediğiniz sütun harfini giriniz !" _
    & Chr(10) & Chr(10) & "Örnek :  A" _
    & Chr(10) & Chr(10) & "Sıralama yapmak istemiyorsanız " _
    & Chr(10) & "boş bırakıp tamam ya da iptal tuşuna tıklayınız.", "Sıralanacak Sütun Bilgisi Girişi")
    
    If Sıralanacak_Sütun = "" Or Sıralanacak_Sütun = False Then GoTo Devam
    
    Satır = 1
    
    For X = 2 To S3.Range("B65536").End(3).Row
        If S3.Cells(X, Sıralanacak_Sütun).Interior.ColorIndex = 38 Then
            S3.Cells(X, 1) = Satır
            Satır = Satır + 1
        End If
    Next
    
    S3.Rows("2:65536").Sort Key1:=S3.Range("A2"), Order1:=xlAscending
    S3.Range("A1") = "SIRA NO (" & Sıralanacak_Sütun & ")"
    
    S3.Cells.EntireColumn.AutoFit
    
Devam:
    Satır = 2
    
    For X = 2 To S2.Range("A65536").End(3).Row
        Set BUL = S1.Range("A:A").Find(S2.Cells(X, 1), LookAt:=xlWhole)
        If BUL Is Nothing Then
            S4.Range("A" & Satır & ":" & Cells(Satır, Sütun).Address(0, 0)).Value = S2.Range("A" & X & ":" & Cells(X, Sütun).Address(0, 0)).Value
            Satır = S4.Range("A65536").End(3).Row + 1
        End If
    Next
    
    S4.Cells.EntireColumn.AutoFit
    
    
    Satır = 2
    
    For X = 2 To S1.Range("A65536").End(3).Row
        Set BUL = S2.Range("A:A").Find(S1.Cells(X, 1), LookAt:=xlWhole)
        If BUL Is Nothing Then
            S5.Range("A" & Satır & ":" & Cells(Satır, Sütun).Address(0, 0)).Value = S1.Range("A" & X & ":" & Cells(X, Sütun).Address(0, 0)).Value
            Satır = S5.Range("A65536").End(3).Row + 1
        End If
    Next
    
    S5.Cells.EntireColumn.AutoFit
    
    S3.Select
    
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set S4 = Nothing
    Set S5 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

unur · 2 Nisan 2011

Korhan Bey Teşekkürler elinize sağlık.

unur · 5 Nisan 2011

Korhan Bey;
Kendim yapmaya çalıştım ama kodlar birbirine bağlı olduğu için beceremedim.Filtreleme işlemini aktarma esnasında değilde Hangi sutunu göre filtreleme isteğimiz karşılaştırma sayfasında ayrı bir butona atasak. daha kullanışlı olacak sanırım.Bu şekilde yapabilirmiyiz?
Teşekkürler.

unur · 7 Nisan 2011

Güncel....

Korhan Ayhan · 8 Nisan 2011

Selamlar,

Aşağıdaki kodları ayrı modüllere ve butonlara atayarak denermisiniz.

Kod:

Option Explicit
 
Sub SAYFALARI_KARŞILAŞTIR()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, S4 As Worksheet, S5 As Worksheet
    Dim X As Long, Y As Byte, Satır As Integer, Sütun As Byte, BUL As Range
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("mart")
    Set S2 = Sheets("nisan")
    Set S3 = Sheets("karşılaştırma")
    Set S4 = Sheets("gelen per.")
    Set S5 = Sheets("giden per.")
    
    S3.Cells.Delete
    S4.Cells.Delete
    S5.Cells.Delete
    
    Satır = 2
    Sütun = S1.Range("IV1").End(1).Column
    
    S1.Rows(1).Copy S3.Range("A1")
    S1.Rows(1).Copy S4.Range("A1")
    S1.Rows(1).Copy S5.Range("A1")
    
    S3.Range("A:B").Insert
    S3.Range("A1") = "SIRA NO"
    S3.Range("B1") = "AY"
    
    S3.Rows(1).HorizontalAlignment = xlCenter
    S3.Rows(1).Font.Bold = True
    S3.Columns("A:A").HorizontalAlignment = xlCenter
    S4.Rows(1).HorizontalAlignment = xlCenter
    S4.Rows(1).Font.Bold = True
    S5.Rows(1).HorizontalAlignment = xlCenter
    S5.Rows(1).Font.Bold = True
    
    For X = 2 To S1.Range("A65536").End(3).Row
        Set BUL = S2.Range("A:A").Find(S1.Cells(X, 1), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
            For Y = 2 To Sütun
                If S1.Cells(X, Y) <> S2.Cells(BUL.Row, Y) Then
                    S3.Cells(Satır, 2) = S1.Name
                    S3.Cells(Satır + 1, 2) = S2.Name
                    S3.Range("C" & Satır & ":" & Cells(Satır, Sütun + 2).Address(0, 0)).Value = S1.Range("A" & X & ":" & Cells(X, Sütun).Address(0, 0)).Value
                    S3.Range("C" & Satır + 1 & ":" & Cells(Satır + 1, Sütun + 2).Address(0, 0)).Value = S2.Range("A" & BUL.Row & ":" & Cells(BUL.Row, Sütun).Address(0, 0)).Value
                    S3.Cells(Satır, Y + 1).Interior.ColorIndex = 38
                    S3.Cells(Satır + 1, Y + 1).Interior.ColorIndex = 38
                End If
            Next
            Satır = S3.Range("B65536").End(3).Row + 1
        End If
    Next
    
    S3.Cells.EntireColumn.AutoFit
    
    
    Satır = 2
    
    For X = 2 To S2.Range("A65536").End(3).Row
        Set BUL = S1.Range("A:A").Find(S2.Cells(X, 1), LookAt:=xlWhole)
        If BUL Is Nothing Then
            S4.Range("A" & Satır & ":" & Cells(Satır, Sütun).Address(0, 0)).Value = S2.Range("A" & X & ":" & Cells(X, Sütun).Address(0, 0)).Value
            Satır = S4.Range("A65536").End(3).Row + 1
        End If
    Next
    
    S4.Cells.EntireColumn.AutoFit
    
    
    Satır = 2
    
    For X = 2 To S1.Range("A65536").End(3).Row
        Set BUL = S2.Range("A:A").Find(S1.Cells(X, 1), LookAt:=xlWhole)
        If BUL Is Nothing Then
            S5.Range("A" & Satır & ":" & Cells(Satır, Sütun).Address(0, 0)).Value = S1.Range("A" & X & ":" & Cells(X, Sütun).Address(0, 0)).Value
            Satır = S5.Range("A65536").End(3).Row + 1
        End If
    Next
    
    S5.Cells.EntireColumn.AutoFit
    
    S3.Select
    
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set S4 = Nothing
    Set S5 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Kod:

Option Explicit
 
Sub SEÇİLEN_SÜTUNA_GÖRE_SIRALA()
    Dim S1 As Worksheet, X As Long, Satır As Integer, Sıralanacak_Sütun As Variant
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("karşılaştırma")
    
    Sıralanacak_Sütun = InputBox("Lütfen sıralama yapmak istediğiniz sütun harfini giriniz !" _
    & Chr(10) & Chr(10) & "Örnek :  A" _
    & Chr(10) & Chr(10) & "Sıralama yapmak istemiyorsanız " _
    & Chr(10) & "boş bırakıp tamam ya da iptal tuşuna tıklayınız.", "Sıralanacak Sütun Bilgisi Girişi")
    
    If Sıralanacak_Sütun = "" Or Sıralanacak_Sütun = False Then
        MsgBox "İşleminiz iptal edilmiştir !", vbExclamation
        Exit Sub
    End If
    
    Satır = 1
    
    For X = 2 To S1.Range("B65536").End(3).Row
        If S1.Cells(X, Sıralanacak_Sütun).Interior.ColorIndex = 38 Then
            S1.Cells(X, 1) = Satır
            Satır = Satır + 1
        End If
    Next
    
    S1.Rows("2:65536").Sort Key1:=S1.Range("A2"), Order1:=xlAscending
    S1.Range("A1") = "SIRA NO (" & Sıralanacak_Sütun & ")"
    
    S1.Cells.EntireColumn.AutoFit
    
    Set S1 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

baydeniro · 8 Nisan 2011

çok teşekkürler

unur · 10 Nisan 2011

Korhan bey Emeğinize sağlık.

Verdiğiniz kodları kullandım. Biraz daha revize yapabilirseniz mükemmel olacak.

Verileride azalttım daha iyi gözlem yapabilmek için

Sorunlarım şunlar: Farklı olan hücreleri değilde, bir önceki hücreyi boyama yapıyor.

*İlk yazdığınız kodlardaki gibi kişiler arasında boşluk bırakınca daha şık duruyordu sanki.

Süzdürme yaptırdığımız kodlarda A sutununa sıra numarası veriyor.Farklı bir hücrede süzdürme yaptırdığımızda A sutununu temizlemesi için kodlar düzenlenirse düzenli çalışacak. önce O daha sonra N sutununu süzdürürseniz benim anlatmak istediğimi benden iyi anlatıyor excel.
Teşekkürler.

baydeniro · 10 Nisan 2011

Paylaşım için çok teşekkürler. çok yararlı oldu.

unur · 10 Nisan 2011

Yukarıdaki küçük sorunlarıda halledebilirsek daha güzel bir çalışma olacak

unur · 11 Nisan 2011

unur' Alıntı:
Korhan bey Emeğinize sağlık.

Verdiğiniz kodları kullandım. Biraz daha revize yapabilirseniz mükemmel olacak.

Verileride azalttım daha iyi gözlem yapabilmek için

Sorunlarım şunlar: Farklı olan hücreleri değilde, bir önceki hücreyi boyama yapıyor.

*İlk yazdığınız kodlardaki gibi kişiler arasında boşluk bırakınca daha şık duruyordu sanki.

Süzdürme yaptırdığımız kodlarda A sutununa sıra numarası veriyor.Farklı bir hücrede süzdürme yaptırdığımızda A sutununu temizlemesi için kodlar düzenlenirse düzenli çalışacak. önce O daha sonra N sutununu süzdürürseniz benim anlatmak istediğimi benden iyi anlatıyor excel.
Teşekkürler.

Güncel....

Sayfaları karşılaştırıp farklılıkları başka sayfaya aktarmak

unur

Ekli dosyalar

Korhan Ayhan

Administrator

Ekli dosyalar

unur

Merhum İdris SERDAR

Moderatör

unur

Korhan Ayhan

Administrator

unur

Korhan Ayhan

Administrator

unur

unur

Ekli dosyalar

Korhan Ayhan

Administrator

Ekli dosyalar

unur

unur

unur

Korhan Ayhan

Administrator

baydeniro

unur

Ekli dosyalar

baydeniro

unur

unur