Kritere göre benzersiz filtre

[bunyaming]

Merhaba Değerli Üstadlarım

Eklediğim dosyada muhtemelen size basit gelecek bir konuda yardıma ihtiyacım var

sizlerin sayesinde öğrenmeye çalışıyorum

açıklamayı dosya içinde belirttim.

yardımcı olabilecek üstadım kodun açıklamasını da kod bloğuna yazabilirse sevinirim, gelişimim için fayda sağlayacaktır.

teşekkürler

 

[Merhum İdris SERDAR]

Makrosuz.

Tablo ve Özet Tablo ve Dilimleyici kullanılmıştır.

Dosya ekte.

 

[bunyaming]

Makrosuz.

Tablo ve Özet Tablo ve Dilimleyici kullanılmıştır.

Dosya ekte.

Hocam Teşekkürler cevabınız için

yalnız şöyle problem var bunu formülle destekleyeceğim.
daha önceden Sn. Çıtır bana bu şekilde bir örneğin formül ile çözüm yolunu göstermişti(dizi formülü) ama o bile data uzayınca kasılıyor.
Sabahtan beri sizin siteniz de dahil bir çok yerde kendi başıma çözmek için çok uğraştım ama toparlayamadım.
Vba ile çözmek mümkün ise bu yolu öğreneyim benim için ve merak eden arkadaşlarım için çok faydalı olacaktır.

emeğiniz ve zaman ayırdığınız için sonsuz teşekkürler

 

[Haluk]

VBA ile bir çözüm ektedir...

.

 

[bunyaming]

VBA ile bir çözüm ektedir...

.

Çook teşekkürler Haluk Hocam

yapacağım raporlamalarda gösterdiğiniz yöntem fazlasıyla işime yarayacaktır.

Allah razı olsun

iyi akşamlar

 

[Korhan Ayhan]

Alternatif;

Hız bakımından biraz daha performans sağlar.

Sub Benzersiz()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Tablo As Variant, X As Long, Dizi As Object, Liste As Variant
    Dim Kriter As String, Veri As String, Zaman As Double
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Zaman = Timer
    
    Set S1 = Sheets("DATA")
    Set S2 = Sheets("BİLGİ")
    
    S2.Range("B2:B" & S2.Rows.Count).ClearContents
    Kriter = UCase(Replace(Replace(S2.Range("A2").Value, "ı", "I"), "i", "İ"))

    Tablo = S1.Range("A1").CurrentRegion.Value
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    ReDim Liste(1 To UBound(Tablo), 1 To 1)
    
    For X = 1 To UBound(Tablo)
        Veri = UCase(Replace(Replace(Tablo(X, 10), "ı", "I"), "i", "İ"))
        If Veri = Kriter Then
            If Not Dizi.Exists(Tablo(X, 6)) Then
                Dizi.Add Tablo(X, 6), Nothing
                Say = Say + 1
                ReDim Preserve Liste(1 To UBound(Tablo), 1 To 1)
                Liste(Say, 1) = Tablo(X, 6)
            End If
        End If
    Next
    
    S2.Range("B2").Resize(Dizi.Count, 1) = Liste
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00000")
End Sub

 

[bunyaming]

Alternatif;

Hız bakımından biraz daha performans sağlar.

Sub Benzersiz()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Tablo As Variant, X As Long, Dizi As Object, Liste As Variant
    Dim Kriter As String, Veri As String, Zaman As Double
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Zaman = Timer
   
    Set S1 = Sheets("DATA")
    Set S2 = Sheets("BİLGİ")
   
    S2.Range("B2:B" & S2.Rows.Count).ClearContents
    Kriter = UCase(Replace(Replace(S2.Range("A2").Value, "ı", "I"), "i", "İ"))

    Tablo = S1.Range("A1").CurrentRegion.Value
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    ReDim Liste(1 To UBound(Tablo), 1 To 1)
   
    For X = 1 To UBound(Tablo)
        Veri = UCase(Replace(Replace(Tablo(X, 10), "ı", "I"), "i", "İ"))
        If Veri = Kriter Then
            If Not Dizi.Exists(Tablo(X, 6)) Then
                Dizi.Add Tablo(X, 6), Nothing
                Say = Say + 1
                ReDim Preserve Liste(1 To UBound(Tablo), 1 To 1)
                Liste(Say, 1) = Tablo(X, 6)
            End If
        End If
    Next
   
    S2.Range("B2").Resize(Dizi.Count, 1) = Liste
   
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00000")
End Sub

Teşekkürler Korhan Hocam
emeğinize sağlık

 

[HsNKgL]

Alternatif;

Hız bakımından biraz daha performans sağlar.

Sub Benzersiz()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Tablo As Variant, X As Long, Dizi As Object, Liste As Variant
    Dim Kriter As String, Veri As String, Zaman As Double
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Zaman = Timer
   
    Set S1 = Sheets("DATA")
    Set S2 = Sheets("BİLGİ")
   
    S2.Range("B2:B" & S2.Rows.Count).ClearContents
    Kriter = UCase(Replace(Replace(S2.Range("A2").Value, "ı", "I"), "i", "İ"))

    Tablo = S1.Range("A1").CurrentRegion.Value
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    ReDim Liste(1 To UBound(Tablo), 1 To 1)
   
    For X = 1 To UBound(Tablo)
        Veri = UCase(Replace(Replace(Tablo(X, 10), "ı", "I"), "i", "İ"))
        If Veri = Kriter Then
            If Not Dizi.Exists(Tablo(X, 6)) Then
                Dizi.Add Tablo(X, 6), Nothing
                Say = Say + 1
                ReDim Preserve Liste(1 To UBound(Tablo), 1 To 1)
                Liste(Say, 1) = Tablo(X, 6)
            End If
        End If
    Next
   
    S2.Range("B2").Resize(Dizi.Count, 1) = Liste
   
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00000")
End Sub

S.A.

Buradaki örnekte hücrede yazan değere göre değilde P harfi ile başlayanları bulup listeletebilirmiyiz...