Veri Filtreleme ve Belirlenen Yere Virgülle Ayrılmış Verilerin Yazması

[rivedex]

Elimde bir veri var. A sütunu Kalem Kodu ismine sahip ve altında kodların bulunduğu veri grubuna sahip. Bu veri gurubunda birbirini tekrarlayan veriler var. M sütununda Org ismine sahip ve altında şube ismi kısaltmalarının bulunduğu veri grubu var. U sütununda ise KONTROL ismine sahip ve altında Koli veya Shrink yazan veri grubu mevcut. Filtrelemek istediğim kodu arattığımda o kodu kullanan şubelerin karşılığı olarak Koli mi Shrink mi olduğu yazıyor. Ve benim de Koli ve Shrink diye belirlediğim bir hücre yeri var. Bu belirlediğim yere arattığım kodun yani o kodu kullanan şubeler çıkıyor o şubelerin Koli mi Shrink mi kullandığını belirlemiş olduğum yere virgülle ayrılarak yazılmasını istiyorum. Şubeler virgülle belirlemiş olduğum yere yazsın ve sadece arama kriteri içindeki verileri yazsın. Nasıl yapabilirim acaba ?

ORNEK.xlsx dosyasını indir - download

ORNEK.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

 

[Korhan Ayhan]

Profilinizdeki sürüm bilgisi doğruysa makrolu çözüm üretmek gerekir.

 

[rivedex]

Profilinizdeki sürüm bilgisi doğruysa makrolu çözüm üretmek gerekir.

Evet office 2013 sürümü kullanıyorum

 

[Korhan Ayhan]

Deneyiniz.

Kullanım şekli ; =K_TEXTJOIN($B$2:$B$83;$C$2:$C$83;A90;",")

Option Explicit

Function K_TEXTJOIN(Concatenate_Area As Range, Criteria_Rng As Range, Criteria As Variant, Optional Seperator As String = "-")
    Dim My_Array As Object, Rng As Range, Count_Data As Long, X_Row As Long
 
    Application.Volatile True
 
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
    X_Row = 0
    Count_Data = 0
     
    For Each Rng In Criteria_Rng
        X_Row = X_Row + 1
        If Rng.RowHeight > 0 Then
            If Rng.Value = Criteria.Value Then
                If Not My_Array.Exists(Concatenate_Area.Cells(X_Row, 1).Value) Then
                    Count_Data = Count_Data + 1
                    My_Array.Add Concatenate_Area.Cells(X_Row, 1).Value, Count_Data
                End If
            End If
        End If
    Next
 
    If Sheets(Concatenate_Area.Parent.Name).FilterMode Then
        K_TEXTJOIN = VBA.Join(My_Array.Keys, Seperator)
    Else
        K_TEXTJOIN = ""
    End If

    Set My_Array = Nothing
End Function

 

[rivedex]

Deneyiniz.

Kullanım şekli ; =K_TEXTJOIN($B$2:$B$83;$C$2:$C$83;A90;",")

Option Explicit

Function K_TEXTJOIN(Concatenate_Area As Range, Criteria_Rng As Range, Criteria As Variant, Optional Seperator As String = "-")
    Dim My_Array As Object, Rng As Range, Count_Data As Long, X_Row As Long

    Application.Volatile True

    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
    X_Row = 0
    Count_Data = 0
    
    For Each Rng In Criteria_Rng
        X_Row = X_Row + 1
        If Rng.RowHeight > 0 Then
            If Rng.Value = Criteria.Value Then
                If Not My_Array.Exists(Concatenate_Area.Cells(X_Row, 1).Value) Then
                    Count_Data = Count_Data + 1
                    My_Array.Add Concatenate_Area.Cells(X_Row, 1).Value, Count_Data
                End If
            End If
        End If
    Next

    If Sheets(Concatenate_Area.Parent.Name).FilterMode Then
        K_TEXTJOIN = VBA.Join(My_Array.Keys, Seperator)
    Else
        K_TEXTJOIN = ""
    End If

    Set My_Array = Nothing
End Function

Çok ama çok teşekkür ederim beni büyük bir yükten kurtardınız. Gerçekten çok mutlu oldum, sağ olun. Allah binlerce kez razı olsun

 

[Korhan Ayhan]

Rica ederim..

Ek olarak aşağıdaki linki incelemenizde fayda var.

Bilgi - Profillerde yazan "Ofis Sürümü ve Dili" bilgisi hakkında

Merhaba Değerli Forum Üyeleri, Belki dikkatinizi çekmiştir. Son zamanlarda birçok üyemize açtıkları başlıklarda cevap vermeden önce "Kullandığınız ofis sürümü ve dili nedir?" şeklinde mesaj yazıyorum. Bu alanın kullanım amacı sizlere verilecek cevaplar için önem arz etmektedir. Bu sebeple bu...

www.excel.web.tr

 

[rivedex]

Deneyiniz.

Kullanım şekli ; =K_TEXTJOIN($B$2:$B$83;$C$2:$C$83;A90;",")

Option Explicit

Function K_TEXTJOIN(Concatenate_Area As Range, Criteria_Rng As Range, Criteria As Variant, Optional Seperator As String = "-")
    Dim My_Array As Object, Rng As Range, Count_Data As Long, X_Row As Long

    Application.Volatile True

    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
    X_Row = 0
    Count_Data = 0
    
    For Each Rng In Criteria_Rng
        X_Row = X_Row + 1
        If Rng.RowHeight > 0 Then
            If Rng.Value = Criteria.Value Then
                If Not My_Array.Exists(Concatenate_Area.Cells(X_Row, 1).Value) Then
                    Count_Data = Count_Data + 1
                    My_Array.Add Concatenate_Area.Cells(X_Row, 1).Value, Count_Data
                End If
            End If
        End If
    Next

    If Sheets(Concatenate_Area.Parent.Name).FilterMode Then
        K_TEXTJOIN = VBA.Join(My_Array.Keys, Seperator)
    Else
        K_TEXTJOIN = ""
    End If

    Set My_Array = Nothing
End Function

Korhan Bey Merhaba,

Peki bu çıkan sonuçları başka bir sheeteki Koli ve Sherink yazan sütuna getirebilmek için nasıl bir yol izlemem gerekir.? Diğer Sheette kodlar sadece 1 sefer yazılmış ve sadece sonuç olarak Koli kısmına şubeler ve shirink kısmına şubeler yazılacak.

 

[Korhan Ayhan]

Önerdiğim kullanıcı tanımlı fonksiyonu excelin yerleşik fonksiyonları gibi kullanabilirsiniz. Kurguda hata yoksa sonuç üretmesi gerekir.

 

[rivedex]

Önerdiğim kullanıcı tanımlı fonksiyonu excelin yerleşik fonksiyonları gibi kullanabilirsiniz. Kurguda hata yoksa sonuç üretmesi gerekir.

Denedim fakat sonuç getirmedi, ya da ben beceremedim

 

[Korhan Ayhan]

İnceleyiniz.

Harici Link (Silinebilir) ; https://dosya.co/55ihm1sllz1e/ORNEK_(KTF).xlsm.html

 

[rivedex]

İnceleyiniz.

Harici Link (Silinebilir) ; https://dosya.co/55ihm1sllz1e/ORNEK_(KTF).xlsm.html

Attığınız şekilde oluyor fakat bendeki format aşağıdaki eklediğim linkteki gibi, ona uyarlarınca çalıştıramadım Korhan Bey

İndir ORNEK (KTF)

Dosyayı indir ORNEK (KTF)

dosya.co

 

[Korhan Ayhan]

Kodu tamamen ilk mesajınızdaki talebinizde belirttiğiniz gibi filtreleme işlemine göre kurgulamıştım. Son mesajda paylaştığınızda dosyadaki yapıda filtre uygulamadığınız için çalışmaması normaldir.

Böyle durumlarda veri bu şekilde ben sonucu bu şekilde görmek istiyorum derseniz boşa kürek çekmemiş oluruz.

 

[rivedex]

Kodu tamamen ilk mesajınızdaki talebinizde belirttiğiniz gibi filtreleme işlemine göre kurgulamıştım. Son mesajda paylaştığınızda dosyadaki yapıda filtre uygulamadığınız için çalışmaması normaldir.

Böyle durumlarda veri bu şekilde ben sonucu bu şekilde görmek istiyorum derseniz boşa kürek çekmemiş oluruz.

Yok siz yanlış anladınız Korhan Bey. Yapmış olduğunuz kurgu sayesinde ben çalışmamı tamamladım. Ve çok çok işime yaradı. Onu kullanmak zorundaydım çünkü görmem gereken şeyler vardı çalışmanın içinde. Bugün size söylediğim şey, extra bu kurgu sayesinde olabilir mi diye sormaktı aslında, yanlış anlaşılma için kusura bakmayın.

 

[Korhan Ayhan]

İnceleyiniz.

Harici Link (Silinebilir) ; https://dosya.co/n7pmt0fzfvry/ORNEK_(KTF-2).xlsm.html

 

[rivedex]

İnceleyiniz.

Harici Link (Silinebilir) ; https://dosya.co/n7pmt0fzfvry/ORNEK_(KTF-2).xlsm.html

Korhan Bey gerçekten nasıl teşekkür edeceğimi bilmiyorum, her iki kod da muhteşem çalıştı. Çok teşekkür ederim elinize emeğinize sağlık, harikasınız.