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

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodları denermisiniz. Veriler arasında boşluk verdirme işlemini kaldırmamın sebebi sıralama istediğiniz içindir. Ayrıca sıralama işleminde pembe renkli hücreler dikkate alınmaktadır. Hücre pembe renkli ise "A" sütununa sıra no verilmektedir. Bu sebeple eğer seçtiğiniz sütunda pembe renkli hücre yoksa zaten sıra no verilmeyecektir.

Aşağıdaki sıralama işlemini yapan kodda daha önce verilmiş olan sıra numaraları silinecek şekilde revize edilmiştir.


Karşılaştırma işlemi için;

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 + 2).Interior.ColorIndex = 38
                    S3.Cells(Satır + 1, Y + 2).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

Sıralama işlemi için;

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")
    S1.Range("A2:A65536").ClearContents
    
    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 (" & UCase(Replace(Replace(Sıralanacak_Sütun, "i", "İ"), "ı", "I")) & ")"
    
    S1.Cells.EntireColumn.AutoFit
    
    Set S1 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[unur]

Korhan Bey çok teşekkürler Allah Razı olsun, Epey bir emek verdiniz.Elinize sağlık.

 

[ergin067]

bana excel konusunda yardım edecek varmı

 

[unur]

Sağolsunlar Korhan beyin emekleriyle ekte bulunan dosyayı istediğim hale getirdim.
Şimdi bu dosyaya küçük bir eklemede bulunabilirmiyiz yardımlarınızla.
Karşılaştırma sayfasında mart ve nisan sayfalarında hangi kalemlerde değişiklik olduğunu bulup onları renklendiriyor.
Şimdi yapmak istediğim (örnekte olduğu gibi)bir özet rapor sayfası oluşturup karşılaştırma sayfasında hangi verilerde değişiklik olduysa onların isimlerini A sutununa yazdırıp karşısında kaç kişide değişiklik olmuş onları rakam olarak yazdırmak bir nevi renkli hangi kalemin altında kaç tane renkli satır var.
Yardımcı olacak arkadaşlara şimdiden teşekkürler.

 

[unur]

Güncel....

 

[unur]

Güncel.....

 

[unur]

Korhan Bey; bu işi sizin sayenizde buraya kadar getirdik;Gene sizden yardım geleceğini düşünüyorum.Teşekkürler.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub ÖZET_RAPOR()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long
    Dim X As Long, Y As Byte, Satır As Long, BUL As Range
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("karşılaştırma")
    Set S2 = Sheets("özet rapor")
    
    S2.Range("A2:B65536").ClearContents
    Son = S1.Range("B65536").End(3).Row
    
    For Y = 4 To S1.Cells(1, Columns.Count).End(1).Column
        For X = 2 To Son
            If S1.Cells(X, Y).Interior.ColorIndex = 38 Then
                If WorksheetFunction.CountIf(S2.Range("A:A"), S1.Cells(1, Y)) = 0 Then
                    Satır = IIf(S2.Range("A3") = "", 3, S2.Cells(65536, "A").End(3).Row + 1)
                    S2.Cells(Satır, "A") = S1.Cells(1, Y)
                    S2.Cells(Satır, "B") = 1
                Else
                    Set BUL = S2.Range("A:A").Find(S1.Cells(1, Y), , , xlWhole)
                    If Not BUL Is Nothing Then
                    S2.Cells(BUL.Row, "B") = (S2.Cells(BUL.Row, "B") + 1)
                    End If
                End If
            End If
        Next
    Next
 
    If Satır >= 3 Then
        S2.Range("IV1") = 2
        S2.Range("IV1").Copy
        S2.Range("B3:B" & Satır).PasteSpecial Paste:=xlPasteValues, Operation:=xlDivide
        S2.Range("IV1").ClearContents
    End If
 
    S2.Select
    Range("A1").Select
 
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[unur]

Teşekkürler Korhan bey, Allah razı olsun.
Proplem olan bir şey değil ama
Aşağıdaki gibi bir uyarı çıkıyor.Eksik yaptığım birşeymi var acaba?

 

[Korhan Ayhan]

Selamlar,

Önerdiğim kodu eklediğiniz örnek dosyada test ederek vermiştim. Ben bu şekilde bir hata ile karşılaşmadım. Dosyanızda bozulma olabilir.

 

[unur]

Teşekkürler Korhan bey; Evde denedim proplem çıkmadı galiba işyerindeki dosyada proplem var.Teşekkürler emekleriniz için.