Benzer sayfaları bulmak 2

[serkol64]

Merhaba daha önce birincisini 12.06.2025 tarihinde yazıp özgür beyden cevap almıştım. Aynı makro kodunu tekrar denedim fare ilmeci devamlı dönerken benzer sayfaların tablosunu veriyor. Benzer sayları tek bir sayfaya indirmek istiyorum yani aynı mükerrer içeriği teke indirmem lazım. Devamlı dönen o yuvarlağın dönmesini mi beklemem lazım anlayamadım. 2.dosyada fare ilmeci listenin yanında sürekli dönüyor

 

[serkol64]

niye soruma cevap verilmiyor anlamadım ?

 

[Korhan Ayhan]

Sorunuz tam olarak anlaşılmamış olabilir.

Hangi veriyi ne ile karşılaştırmak istiyorsunuz bunu detaylı olarak örneklendirerek açıklarsanız müsait olan üyeler destek vereceklerdir.

 

[serkol64]

Excel çalışma kitabında sayfa isimleri farlı da olsa noktası virgülüne kadar %100 benzer olan sayfalar var. Benzer sayları bulma ile ilgi makro kodunu uyguladım hangi sayların benzediği listesini gördüm buraya kadar tamam da ; sorum şu bu benzer sayfaları teke nasıl düşürebilirim ?

 

[Korhan Ayhan]

Deneyiniz.

DİKKAT ! Silme işlemi olacağı için verilerinizi yedekledikten sonra kodu deneyiniz...

İlk makro mükerrer sayfaları "KOPYA_SAYFALAR" isimli sayfaya listeler ve sayfa sekme rengini KIRMIZI yapar.

Mükerrerlik durumunu kontrol ettikten sonra silme kodunu çalıştırıp mükerrer sayfaları silebilirsiniz.

Silme işlemi A sütunundaki isme göre yapılmaktadır.

Option Explicit

Sub AyniIcerikliSayfalariListele()

    Dim dict As Object
    Dim ws As Worksheet, rapor As Worksheet
    Dim sig As String
    Dim satir As Long
   
    Set dict = CreateObject("Scripting.Dictionary")
   
    ' Eski raporu sil
    Application.DisplayAlerts = False
    On Error Resume Next
    Worksheets("KOPYA_SAYFALAR").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
   
    ' Yeni rapor sayfası
    Set rapor = Worksheets.Add
    rapor.Name = "KOPYA_SAYFALAR"
   
    rapor.Range("A1:D1").Value = Array("Kopya Sayfa", "Orijinal Sayfa", "Durum", "İmza")
    rapor.Rows(1).Font.Bold = True
   
    satir = 2
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    For Each ws In ThisWorkbook.Worksheets
       
        If ws.Name <> rapor.Name Then
           
            sig = SheetSignature(ws)
           
            If dict.exists(sig) Then
                ' Kopya bulundu
                rapor.Cells(satir, 1).Value = ws.Name
                rapor.Cells(satir, 2).Value = dict(sig)
                rapor.Cells(satir, 3).Value = "KOPYA"
                rapor.Cells(satir, 4).Value = sig
               
                ws.Tab.Color = RGB(255, 0, 0)
                satir = satir + 1
            Else
                dict.Add sig, ws.Name
            End If
           
        End If
       
    Next ws
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    rapor.Columns("A:D").AutoFit
   
    MsgBox "Kopya sayfalar listelendi." & vbCrLf & _
           "Silmeden önce 'KOPYA_SAYFALAR' sayfasını kontrol edin.", vbInformation
End Sub

Sub ListeyeGoreKopyalariSil()

    Dim rapor As Worksheet
    Dim i As Long, son As Long
    Dim ws As Worksheet
   
    Set rapor = Worksheets("KOPYA_SAYFALAR")
    son = rapor.Cells(rapor.Rows.Count, "A").End(xlUp).Row
   
    If MsgBox("Listelenen KOPYA sayfalar silinecek. Emin misiniz?", _
              vbYesNo + vbExclamation) = vbNo Then Exit Sub
   
    Application.DisplayAlerts = False
   
    For i = 2 To son
        On Error Resume Next
        Set ws = Worksheets(rapor.Cells(i, 1).Value)
        If Not ws Is Nothing Then ws.Delete
        Set ws = Nothing
        On Error GoTo 0
    Next i
   
    Application.DisplayAlerts = True
   
    MsgBox "Kopya sayfalar silindi.", vbInformation
End Sub

Private Function SheetSignature(ws As Worksheet) As String
    Dim arr, r As Long, c As Long
    Dim sb As String
   
    With ws.UsedRange
        If .Cells.Count = 1 And IsEmpty(.Cells(1, 1)) Then
            SheetSignature = "EMPTY"
            Exit Function
        End If
       
        arr = .Value
    End With
   
    For r = 1 To UBound(arr, 1)
        For c = 1 To UBound(arr, 2)
            sb = sb & "|" & CStr(arr(r, c))
        Next c
    Next r
   
    SheetSignature = sb
End Function

 

[serkol64]

Teşekkür ederim, büyük bir zahmetten kurtardınız.