belli bir başvuruya göre benzersiz listeleme

[euphrates55]

merhabalar, belli bir başvuruya göre benzersiz listeleme yapmak istiyorum.

 

[veyselemre]

Sub test()
    Dim sonA As Long, i As Long, ii As Long, al As String
    Dim w(1 To 3), y, itms

    sonA = Cells(Rows.Count, "A").End(3).Row

    With CreateObject("Scripting.Dictionary")

        For i = 2 To sonA
            al = Cells(i, "A").Value
            If Not .exists(al) Then
                w(1) = al
                w(2) = Cells(i, "B").Value
                w(3) = Cells(i, "C").Value
                .Add al, w
            Else
                y = .Item(al)
                y(2) = y(2) & "," & Cells(i, "B").Value
                y(3) = y(3) & "," & Cells(i, "C").Value
                .Item(al) = y
            End If
        Next i
        If .Count > 0 Then
            itms = .itemS
            Range("K2:K" & Rows.Count).ClearContents
            For i = LBound(itms) To UBound(itms)
                Cells(i + 2, 11) = itms(i)(1)
                For ii = 2 To 3
                    .RemoveAll
                    For Each y In Split(itms(i)(ii), ",")
                        .Item(y) = Null
                    Next y
                    Cells(i + 2, 10 + ii) = Join(.keys, " / ")
                Next ii
            Next i
        End If
    End With
End Sub

 

[euphrates55]

teşekkürler, zahmet verdim... formülle ya da ktf yapma şansımız olabilir mi? başka yerlerde de kullanabilmem açısından daha hoş olacaktır benim için.

 

[Korhan Ayhan]

Formülle yapılır ama veri sayınız çoksa çok verimli olmaz. KTF daha uygun olabilir.

 

[euphrates55]

Function benzersizbirleştir(xRg As Range, xChar As String) As String
    Dim xCell As Range
    Dim xDic As Object
    Set xDic = CreateObject("Scripting.Dictionary")
    For Each xCell In xRg
        xDic(xCell.Value) = Empty
    Next
    benzersizbirleştir = Join$(xDic.Keys, xChar)
    Set xDic = Nothing
End Function

daha önce kullandığım bir ktf var ama seçili alanda benzersiz birleştirme yapıyor, bu ktf ye şart ekleyebilir miyiz. yani sadece belli bir koşulu sağlayan kısımların birleştirilmesi işlemi

 

[Korhan Ayhan]

Deneyiniz.

Kullanıcı tanımlı fonksiyonlarda benzersiz ve sıralama opsiyonları vardır. Fonksiyonların parametrelerini incelerseniz görebilirsiniz.

 

[euphrates55]

çok güzel, kullanışlı olmuş. teşekkürler. sanırım tek söyleyebileceğim ayraç kısmında "/" bu kısım yani, eğer boş hücre varsa en başa / işareti koyarak başlıyor. belki boşları atla seçeneği eklenebilir. başkalarının da kullanacağı çok güzel bir fonksiyon olduğu için belki bunu da eklemek istersiniz.

DÜŞEYARA_BİRLEŞTİR = Join(Liste, ", ")

bu kısımda ben virgül kullandım ve boş olan yer olduğu için virgülle başlıyor.

kolaylıklar dilerim...

 

[Korhan Ayhan]

Üstteki mesajımda ki dosyayı revize ettim.

Birleştirme ayıracını da opsiyonal olacak şekilde düzenledim. Varsayılana olarak virgül ve boşluk (", ") şekilde ayarladım.

Boş olan hücreler işleme dahil olmamaktadır.

 

[euphrates55]

Üstteki mesajımda ki dosyayı revize ettim.

Birleştirme ayıracını da opsiyonal olacak şekilde düzenledim. Varsayılana olarak virgül ve boşluk (", ") şekilde ayarladım.

Boş olan hücreler işleme dahil olmamaktadır.

Çok teşekkürler tekrardan, yine bir not düşeyim. filtreleme yapıldığında sadece filtrelenen alanda işlem yapıyor. kiminin işine gelebilir, kiminin gelmeyebilir. iyi günler.
izninizle kodu da eklemek isterim.

Option Explicit

Function BENZERSİZ(Alan As Range, Kaçıncı_Benzersiz As Long, Optional Sırala As Byte = 1)
    Dim Dizi As Object, Hücre As Range, Liste As Variant
  
    Application.Volatile True
  
    Set Dizi = CreateObject("System.Collections.ArrayList")
  
    For Each Hücre In Alan
        If Hücre.Value <> "" Then
            If Hücre.Height <> 0 Then
                If Dizi.Contains(UCase(Replace(Replace(Hücre.Value, "ı", "I"), "i", "İ"))) = False Then
                    Dizi.Add UCase(Replace(Replace(Hücre.Value, "ı", "I"), "i", "İ"))
                End If
            End If
        End If
    Next
  
    Select Case Sırala
        Case 0
        Case 1: Dizi.Sort
        Case 2: Dizi.Reverse
    End Select
  
    Liste = Dizi.ToArray
  
    BENZERSİZ = Liste(Kaçıncı_Benzersiz - 1)
End Function

Function DÜŞEYARA_BİRLEŞTİR(Aranan_Veri As Range, Alan As Range, Sütun_İndis_Sayısı As Integer, _
                            Optional Benzersiz As Boolean = True, Optional Sırala As Byte = 1, Optional Ayıraç As String = ", ")
    Dim Dizi As Object, Hücre As Range, Liste As Variant
  
    Application.Volatile True
  
    Set Dizi = CreateObject("System.Collections.ArrayList")
  
    For Each Hücre In Alan.Columns(1).Cells
        If Hücre.Value <> "" Then
            If Hücre.Height <> 0 Then
                If Hücre.Value = Aranan_Veri.Value Then
                    If Hücre.Offset(, Sütun_İndis_Sayısı - 1).Value <> "" Then
                        If Benzersiz Then
                            If IsNumeric(Hücre.Offset(, Sütun_İndis_Sayısı - 1).Value) Then
                                If Dizi.Contains(Hücre.Offset(, Sütun_İndis_Sayısı - 1).Value) = False Then
                                    Dizi.Add Hücre.Offset(, Sütun_İndis_Sayısı - 1).Value
                                End If
                            Else
                                If Dizi.Contains(UCase(Replace(Replace(Hücre.Offset(, Sütun_İndis_Sayısı - 1).Value, "ı", "I"), "i", "İ"))) = False Then
                                    Dizi.Add UCase(Replace(Replace(Hücre.Offset(, Sütun_İndis_Sayısı - 1).Value, "ı", "I"), "i", "İ"))
                                End If
                            End If
                        Else
                            If IsNumeric(Hücre.Offset(, Sütun_İndis_Sayısı - 1).Value) Then
                                Dizi.Add Hücre.Offset(, Sütun_İndis_Sayısı - 1).Value
                            Else
                                Dizi.Add UCase(Replace(Replace(Hücre.Offset(, Sütun_İndis_Sayısı - 1).Value, "ı", "I"), "i", "İ"))
                            End If
                        End If
                    End If
                End If
            End If
        End If
    Next
  
    Select Case Sırala
        Case 0
        Case 1: Dizi.Sort
        Case 2: Dizi.Reverse
    End Select
  
    Liste = Dizi.ToArray
  
    DÜŞEYARA_BİRLEŞTİR = Join(Liste, Ayıraç)
End Function

kullanımı

=DÜŞEYARA_BİRLEŞTİR($X3;$A$2:$Q$367;17;DOĞRU;0;", ")

aranacak değer, aranacak aralık, aralıktaki sıralanacak olan sütunun sayısı (kaçıncı), benzersiz mi olsun (doğru=evet), boşluklar atlansın mı?(0=evet), aradaki imlecin ne olacağı

 

[Korhan Ayhan]

Merhaba,

Evet filtrelenmiş alandaki veriler üzerinden sonuç verecek şekilde dizayn ettim. Bu şekilde daha işlevsel olduğunu düşündüm. Dileyen bu özelliği kaldırabilir.

Ayrıca kullanım örneğinde "BOŞLUKLAR ATLANSIN MI" parametresi yoktur. O bölümdeki sıfır değeri sıralama işlemi için kullanılmaktadır. Boşluklar fonksiyon içinde koşul satırı olarak eklenmiştir.

 

[Korhan Ayhan]

Fonksiyon kullanımları şu şekilde;

=BENZERSİZ(Hücre_Aralığı;Kaçıncı_Benzersiz;Sırala)

Hücre_Aralığı; benzersiz verilerin bakılacağı hücre aralığıdır.
Kaçıncı_Benzersiz; fonksiyon sonucunda benzersiz veri listesi oluşacaktır. Bu listedeki kaçıncı sıradaki veriyi almak istiyorsanız bu bölüme o sıra değerini yazıyoruz.
Sırala; bu özellik opsiyoneldir. Varsayılan olarak A-Z sıralamasını yapar. (0 tablodaki veri sırası - 1 A-Z sıralama - 2 Z-A sıralama)


=DÜŞEYARA_BİRLEŞTİR(Aranan_Veri;Hücre_Aralığı;Sütun_İndis_Sayısı;Benzersiz;Sırala;Ayıraç)

Aranan_Veri; belirtilen hücre aralığında aynı aranacak veridir. Aynı DÜŞEYARA fonksiyonundaki gibi hücre aralığının ilk sütununda arama yapılır.
Hücre_Aralığı; aranacak verinin ve karşılığında istenen sonuç verilerinin bulunduğu hücre aralığıdır.
Sütun_İndis_Sayısı; aranan veri bulunduğunda hücre aralığındaki kaçıncı sütundaki veriyi istediğimizi belirttiğimiz parametredir.
Benzersiz; bu özellik opsiyoneldir. Varsayılan olarak bulunan veriler arasından tekrarsız olacak şekilde verileri listeler.
Sırala; bu özellik opsiyoneldir. Varsayılan olarak A-Z sıralamasını yapar. (0 tablodaki veri sırası - 1 A-Z sıralama - 2 Z-A sıralama)
Ayıraç; bu özellik opsiyoneldir. Varsayılan olarak ", " (virgül+boşluk) ile bulunan verileri birleştirir.

Fonksiyonlardaki opsiyonel bölümler boş bırakılabilir. Bu durumda varsayılan ayarlar geçerli olacaktır.

Her iki fonksiyonda boş hücreleri işleme dahil etmez. Ayrıca fonksiyonlar eğer alanda filtre uygulanmışsa ya da gizli satırlar varsa bunları işleme almaz. Sadece görünür hücreler üzerinde işlem yapar.