Soru Tüm sayfalarda sadece belirli sütunlarda arama

[reosman]

https://www.excel.web.tr/threads/sayfalarda-muekerrer-kayit-kontrolue.192180/#post-1090298

Saygıdeğer hocalarım, Yukarıdaki Korhan Ayhan beyin eklediği örneğe göre
Ben tüm sayfaların D sütunlarında yeni yazılacak kayıtları değil yazılı tüm kayıtların kontrolünü yapmak istiyorum.
Bunun için yukarıdaki örneğinizde nasıl değişiklik yapmak gerekiyor. Teşekkür ederim.

Hocalarım ayrıca,

Private Sub CommandButton1_Click()
Dim k As Range, ilk_adres As String, a As Long
Dim i As Long, syf As String
ListBox1.Clear
If TextBox1.Value = "" Then
MsgBox "Lütfen Sicil Numarasını Giriniz !!!", 16, "Dikkat"
End If
If TextBox1.Value = "" Then Exit Sub
ReDim myarr(1 To 3, 1 To 1)
For i = 1 To ComboBox1.ListCount - 1
If ComboBox1.Value <> "HEPSİ" Then
syf = ComboBox1.Value
Else
syf = ComboBox1.Column(0, i)
End If
Set k = Sheets(syf).Cells.Find(TextBox1.Value, , xlValues, xlWhole, , 1)
If Not k Is Nothing Then
ilk_adres = k.Address
Do
a = a + 1
ReDim Preserve myarr(1 To 3, 1 To a)
myarr(1, a) = ComboBox1.Column(0, i)
myarr(2, a) = k.Address(False, False)
myarr(3, a) = k.Value
Set k = Sheets(syf).Cells.FindNext(k)
Loop While ilk_adres <> k.Address And Not k Is Nothing
End If
If ComboBox1.Value <> "HEPSİ" Then Exit For
Next i
Set k = Nothing
Label3.Caption = "Kriterlere Uyan " & Format(a, "#,##0") & " Adet Kayıt Bulundu..!!"
If a > 0 Then
ListBox1.Column = myarr
Erase myarr
MsgBox "Aranan Kayıtlar Listelendi!!", vbOKOnly + vbInformation, "ARA-BUL"
End If
If a < 1 Then MsgBox "Aradığınız Veri Bulunamadı..!!", vbCritical, "DİKKAT"
TextBox1.Value = ""
TextBox1.SetFocus
End Sub

Bu şekilde bir userform var bundada sadece tüm sayfaların D sütununda arama yapmak ve benzerleri
değil birebir uyuşan aynısını bulmak istiyorum. Vereceğiniz bilgiler için şimdiden teşekkür ederim.

 

[reosman]

Userform1 sayfa seçimlerinde hata yapıyor sadece TÜMÜ seçildiğinde doğru veri geliyor.

 

[reosman]

Yardımlarınızı rica ediyorum

 

[reosman]

Rica ediyorum

 

[reosman]

Yardım edebilecek arkadaşlar lütfen rica ediyorum.

 

[reosman]

Sayın hocalarım, uzmanlarım derdime bir çare lütfen. Saygılarımla.

 

[Ömer]

Merhaba,

Deneyiniz.

Private Sub CommandButton1_Click()
Dim k As Range, ilk_adres As String, a As Long
Dim i  As Long, syf As String, myarr()
ListBox1.Clear
If TextBox1.Value = "" Then
    MsgBox "Lütfen Sicil Numarasını Giriniz !!!", 16, "Dikkat"
    End If
If TextBox1.Value = "" Then Exit Sub
        ReDim myarr(1 To 3, 1 To 1)
For i = 1 To ComboBox1.ListCount - 1
    If ComboBox1.Value <> "HEPSİ" Then
        syf = ComboBox1.Value
        Else
        syf = ComboBox1.Column(0, i)
    End If
    Set k = Sheets(syf).Cells.Find(TextBox1.Value, , xlValues, xlWhole, , 1)
    If Not k Is Nothing Then
        ilk_adres = k.Address
        Do
        a = a + 1
        ReDim Preserve myarr(1 To 3, 1 To a)
        myarr(1, a) = syf
        myarr(2, a) = k.Address(False, False)
        myarr(3, a) = k.Value
        Set k = Sheets(syf).Cells.FindNext(k)
        Loop While ilk_adres <> k.Address And Not k Is Nothing
    End If
    If ComboBox1.Value <> "HEPSİ" Then Exit For
    Next i
    Set k = Nothing
    Label3.Caption = "Kriterlere Uyan " & a & " Adet Kayıt Bulundu..!!"
    If a > 0 Then
        ListBox1.Column = myarr
        Erase myarr
        MsgBox "Aranan Kayıtlar Listelendi!!", vbOKOnly + vbInformation, "ARA-BUL"
    End If
    If a < 1 Then MsgBox "Aradığınız Veri Bulunamadı..!!", vbCritical, "DİKKAT"
    TextBox1.Value = ""
    TextBox1.SetFocus
End Sub

 

[reosman]

Hocam öncelikle çok çok teşekkür ederim ilginize.
Paylaştığınız kodu denedim, D sütunu haricindeki kısımlardan da buluyor,
Hocam sadece D sütununda bulunan rakamlardan birebir uyuşanları bulacak.
Size zahmet olacak. Çok teşekkür ederim. Sağlıcakla kalın.

 

[Ömer]

Set k = Sheets(syf).Cells.Find(TextBox1.Value, , xlValues, xlWhole, , 1)

Buradaki Cells yerine [D:D] yazarak deneyiniz.

 

[reosman]

Hocam kodu ekledim yine aynı.

 

[Ömer]

İkinci kısmı belirtmeyi atlamışım.
Set k = Sheets(syf).Cells.FindNext(k)

Aynı şekilde; buradaki Cells yerine de [D:D] yazarak deneyiniz.

 

[reosman]

Hocam çok teşekkür ederim. Harikasınız hocam birde sayfanın en üstünde bir sorum vardı onada bakabilirmisiniz.

 

[Ömer]

Hocam çok teşekkür ederim. Harikasınız hocam birde sayfanın en üstünde bir sorum vardı onada bakabilirmisiniz.

Bu sorunuzu daha detaylı açıklar mısınız.

 

[reosman]

Ömer Hocam, ekteki Korhan Ayhan beyin eklediği örneğe göre
Ben tüm sayfaların D sütunlarında yeni yazılacak kayıtları değil yazılı tüm kayıtların kontrolünü yapmak istiyorum.
Bu örneğe göre yeni yazılacak bilgileri kontrol ederek mükerrer buluyor, lakin benim 30000 yakın verim var
bunları mükerrer kontrol et biçiminde bulup toplu veya tek tek silmek istiyorum. Saygılarımla.

 

[Ömer]

Nasıl kullanacağınızın mantığını anlamadım. Çünkü bu şekilde kullanırsanız kod amacının dışına çıkmış olur gibi geldi bana.
Userformun kod bölümüne ekleyip deneyiniz. ThisWorkbook sayfasındaki kodları silebilirsiniz.

Private Sub UserForm_Initialize()
    Call Mukerrer_Bul
End Sub

Private Sub Mukerrer_Bul()
  
    Dim Sayfa As Worksheet, Alan As Range, Veri As Range, Aranan As String, Bul As Range, Adres As String, Mesaj As String, Dizi As Object, Say As Long
    Dim son_d As Long
  
    Set Alan = Range("D:D")

    Set Dizi = CreateObject("Scripting.Dictionary")
  
    ReDim Liste(1 To 3, 1 To 1)
  
    For Each Sayfa In ThisWorkbook.Worksheets
        son_d = Sayfa.Cells(Rows.Count, "D").End(xlUp).Row
        For Each Veri In Sayfa.Range("D1:D" & son_d)
            If Veri.Value <> Empty Then
                Set Bul = Nothing
                Set Bul = Sayfa.Range(Alan.Address).Find(Veri.Value, , xlValues, xlWhole)
                If Not Bul Is Nothing Then
                    Adres = Bul.Address
                    Do
                        Aranan = Sayfa.Name & "|" & Bul.Address & "|" & Bul.FormulaLocal
                        If Not Dizi.Exists(Aranan) Then
                            Say = Say + 1
                            Dizi.Add Aranan, Say
                            ReDim Preserve Liste(1 To 3, 1 To Say)
                            Liste(1, Say) = Sayfa.Name
                            Liste(2, Say) = Bul.Address
                            Liste(3, Say) = Bul.FormulaLocal
                        End If
                        Set Bul = Sayfa.Range(Alan.Address).FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> Adres
                End If
            End If
        Next
    Next
  
    If Say > 1 Then
        With UserForm1
            .ListBox1.ColumnCount = 3
            .ListBox1.ColumnWidths = "200;70;250"
            .ListBox1.Column = Liste
            .Show
        End With
    End If
  
End Sub

 

[reosman]

Ömer bey mevcut yazılı verileri atıyorum mükerrer bul diyip buldurup gerekirse sileceğim. şu an göndermiş olduğunuzu denemedim. Çok sağolun varolun.

 

[reosman]

Ömer bey ilginize tekrardan çok teşekkür ediyorum o kadar uzun sürüyorki anlatamam.
Yapmak istediğim tüm sayfalardaki D sütunlarını karşılaştırarak mükerrer var ise bulması ve userform üzerinde listelemesi ve uyarı vermesi
ben bulduğu mükerrer kayıtları işaretleyerek sileceğim. Allah razı olsun.

 

[Ömer]

Önemli değil. İşinize yaradığına sevindim.

 

[reosman]

Ömer bey mükkerrer'e bir çözümünüz varmı ?

 

[Ömer]

Bu yüzden nasıl kullanacağınızın mantığını anlamadım demiştim.
Mevcut haliyle işimi gördü deyince sormayı bırakmıştım.
Listboxda listelenmesi ne işinize yarayacak. Silerken hepsini değil de istediklerinizi mi sileceksiniz yada hangi sayfa hangi hücredekileri seçimle mi sileceksiniz. Bunun için 2. bir listbox gerekebilir. Bence önce nasıl bir sistem uygulayacağınızı kurgulamanız gerekir.