Datada işaretleme

[bmutlu966]

Arkadaşlar selam,

Bir sayfada 2 kolonda (Tarih & Rakam)larım var. Aynı tarih ve aynı rakamdan oluşan birden fazla satır da olabiliyor. Burada bulunan her bir satırı Data sayfasında ilgili 2 kolonda aratarak işaretletmek istiyorum. Data sayfasında da benzer birden fazla satır oluyor. Aranan kısmında kaç adet var ise ben o kadar adet işaretletmek istiyorum aslında. Benim daha önce yardım aldığım ve uyarladığım aşağıdaki kodlar aranan kısmında 1 tane olan Datada 10 tane varsa 10 tanesini de işaretliyor. kodlara bu kontrolü koyamadım. Data normalde binlerce satırdan oluştuğu için döngülerle yapmak çok zaman alıyor. Basit bir örnekle daha rahat anlaşılabilir sanırım.

Yardımcı olabilirseniz çok sevinirim.

Sub kontrol_et()
'Application.ScreenUpdating = False

Dim s1 As Worksheet, s2 As Worksheet, a(), w(), dc As Object
Dim i As Long, krt As String, say As Long, j As Byte
    Set s1 = Sheets("Giris")
    Set s2 = Sheets("Data")
    Set dc = CreateObject("scripting.dictionary")
    s2.Select
        a = s1.Range("B3:C" & s1.[B65000].End(xlUp).Row).Value
        For i = 1 To UBound(a)
            krt = CStr(a(i, 1)) & "|" & a(i, 2)
            dc(krt) = ""
        Next i

    Erase a
   
    a = s2.Range("A3:F" & s2.[F65000].End(xlUp).Row).Value
    ReDim w(1 To UBound(a), 1 To 1)
        For i = 1 To UBound(a)
            krt = CStr(a(i, 6)) & "|" & a(i, 4)
            If dc.exists(krt) Then
                w(i, 1) = "X"
            Else
                w(i, 1) = ""
            End If
        Next i
       
   ' Application.ScreenUpdating = 0
        s2.[K3].Resize(UBound(a)) = w
       
   ' Application.ScreenUpdating = 1
'Application.ScreenUpdating = True


End Sub

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Kontrol_Et()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Veri As Variant
    Dim Son As Long, X As Long, Aranan As String, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Giris")
    Set S2 = Sheets("Data")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    S2.Range("K3:K" & S2.Rows.Count).ClearContents
    
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    If Son = 2 Then
        MsgBox "Kontrol edilecek veri bulunamadı!", vbCritical
        Exit Sub
    End If
    
    If Son = 3 Then Son = 4
    
    Veri = S1.Range("B3:C" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Aranan = Veri(X, 2) & "|" & Veri(X, 1)
        If Aranan <> "" Then
            If Not Dizi.Exists(Aranan) Then
                Dizi.Add Aranan, 1
            Else
                Dizi.Item(Aranan) = Dizi.Item(Aranan) + 1
            End If
        End If
    Next
    
    
    Son = S2.Cells(S2.Rows.Count, 4).End(3).Row
    If Son = 2 Then
        MsgBox S2.Name & " sayfasında karşılaştırma yapılacak veri bulunamadı!", vbCritical
        Exit Sub
    End If
    
    If Son = 3 Then Son = 4
    
    Veri = S2.Range("D3:F" & Son).Value
    
    ReDim Liste(1 To Son, 1 To 1)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        Aranan = Veri(X, 1) & "|" & Veri(X, 3)
        If Aranan <> "" Then
            If Dizi.Exists(Aranan) Then
                If Dizi.Item(Aranan) > 0 Then
                    Liste(Say, 1) = "X"
                    Dizi.Item(Aranan) = Dizi.Item(Aranan) - 1
                End If
            End If
        End If
    Next
    
    If Say > 0 Then
        S2.Range("K3").Resize(Say, 1) = Liste
        S2.Select
        MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Eşleşen veri bulunamadı!", vbExclamation
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

 

[bmutlu966]

Korhan hocam öncelikle emekleriniz için teşekkürler.
Sanırım bir yerde hata var. İşaretlemeleri yanlış yapıyor. Yanlış satırları işaretliyor. Örneği çalıştırırsanız anlayacaksınız.

 

[bmutlu966]

Korhan hocam senin kodların üzerinde denemeler yaparak sanırım çözdüm sorunu.

Liste(Say, 1) = "X" satırını Liste(X, 1) = "X"
S2.Range("K3").Resize(Say, 1) = Liste satırını da S2.Range("K3").Resize(X, 1) = Liste
olarak değiştirdiğimde düzeldi. Böylelikle kodların çalışma mantığını da biraz anlamış oldum sanırım. Teşekkürler.

Sub Kontrol_Et()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Veri As Variant
    Dim Son As Long, X As Long, Aranan As String, Say As Long, Zaman As Double

    Zaman = Timer

    Set S1 = Sheets("Giris")
    Set S2 = Sheets("Data")
    Set Dizi = CreateObject("Scripting.Dictionary")

    S2.Range("K3:K" & S2.Rows.Count).ClearContents

    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    If Son = 2 Then
        MsgBox "Kontrol edilecek veri bulunamadı!", vbCritical
        Exit Sub
    End If

    If Son = 3 Then Son = 4

    Veri = S1.Range("B3:C" & Son).Value

    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Aranan = Veri(X, 2) & "|" & Veri(X, 1)
        If Aranan <> "" Then
            If Not Dizi.Exists(Aranan) Then
                Dizi.Add Aranan, 1
            Else
                Dizi.Item(Aranan) = Dizi.Item(Aranan) + 1
            End If
        End If
    Next


    Son = S2.Cells(S2.Rows.Count, 4).End(3).Row
    If Son = 2 Then
        MsgBox S2.Name & " sayfasında karşılaştırma yapılacak veri bulunamadı!", vbCritical
        Exit Sub
    End If

    If Son = 3 Then Son = 4

    Veri = S2.Range("D3:F" & Son).Value

    ReDim Liste(1 To Son, 1 To 1)

    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Aranan = Veri(X, 1) & "|" & Veri(X, 3)
        If Aranan <> "" Then
            If Dizi.Exists(Aranan) Then
                If Dizi.Item(Aranan) > 0 Then
                    Say = Say + 1
                    Liste(X, 1) = "X"
                    Dizi.Item(Aranan) = Dizi.Item(Aranan) - 1
               'Cells(X + 2, "M") = Say
                End If
            End If
        End If
    Next

    If Say > 0 Then
    S2.Range("K3").Resize(X, 1) = Liste
        S2.Select
        MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Eşleşen veri bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

 

[Korhan Ayhan]

Ben de uyarınız üzerine #2 nolu mesajımı revize ettim. Değişik olarak ben SAY değişkenini kullandım. Sizin yaptığınız gibi de kullanılabilir.