Makro ile Aynı Sıralı ürün bulma

[eceLprensi]

[TR][TD]
MErhaba,
Üstadlarım,

Tablosunda A sütününda siparişle B sütununda siparişlerin sıra numarası mevcut.
C sütununa ise Bu ürünlerin sırası aynı olanları PTO olarak yazmak istiyorum.

Yardımcı olabilir misiniz?

Teşekkürler
[/TD]
[TD]

[/TD]
[TD]

[/TD][/TR]
[TR][TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD][/TR]

 

[Muzaffer Ali]

Merhaba.
C2'ye aşağıdaki formülü kopyalayıp alt hücrelere çoğaltın.

=EĞER(ÇOKEĞERSAY(A:A;A2;B:B;B2)>1;"PTO";"")

 

[eceLprensi]

Muzaffer bey,

650.000 satırda çok takılma yapıyor.
Makro ile daha kısa sürmez mi.

 

[Muzaffer Ali]

Aşağıdaki kod ile olur.

Sub Test()
    Dim Bak As Long
    For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        Cells(Bak, "C") = IIf(WorksheetFunction.CountIfs(Range("A:A"), Cells(Bak, "A"), Range("B:B"), Cells(Bak, "B")) > 1, "PTO", "")
    Next
    MsgBox "İşlem tamamlandı."
End Sub

 

[Korhan Ayhan]

Sadece sıra numarası 1 olanlara mı bu ifade yazılacak?

Listede mesela b-2 eşleşmesi de var ama buna ifadeyi yazmamışsınız.

 

[eceLprensi]

Muzaffer Ali bey Teşekkürler,
Korhan bey hakikaten gözden kaçırmışım

Emekleriize teşekkür ederim

 

[Korhan Ayhan]

Bende bir kod önerecektim ama sanırım çözüme ulaştınız.

 

[Korhan Ayhan]

Aşağıdaki kod hız olarak avantaj sağlayacaktır.

Option Explicit

Sub Ayni_Sirali_Urunleri_Bul()
    Dim Zaman As Double, Dizi As Object, Veri As Variant
    Dim Son As Long, X As Long, Say As Long
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Range("C2:C" & Rows.Count).ClearContents
    
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
    
    Veri = Range("A2:B" & Son).Value
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 1)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Dizi.Item(Veri(X, 1) & "|" & Veri(X, 2)) = _
        Dizi.Item(Veri(X, 1) & "|" & Veri(X, 2)) + 1
    Next
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        If Dizi.Item(Veri(X, 1) & "|" & Veri(X, 2)) > 1 Then
            Liste(Say, 1) = "PTO"
        End If
    Next
    
    If Say = 0 Then
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    Else
        Range("C2").Resize(Say) = Liste
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    End If
    
    Set Dizi = Nothing
End Sub

 

[eceLprensi]

Korhan bey,
merhaba,

Çözüme ulaştım fakat data çok uzun olduğundan Bilgisayar kitledi. denemem sonucu 2:45 Saat sürdü förmülün bitmesi.

Sizinki ise 1:29 saniye sürdü. Çok Teşekkür ederim.

Muzaffer Ali Sizede Çok teşekkürler.

Emeklerinize sağlık.