• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

R

rivedex

Katılım
4 Temmuz 2023
Mesajlar
31
Excel Vers. ve Dili
Ofis 2013 TR 64 Bit
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 s6.dosya.tc
 
Profilinizdeki sürüm bilgisi doğruysa makrolu çözüm üretmek gerekir.
 
Deneyiniz.

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

C++: 
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 Ayhan' Alıntı:
Deneyiniz.

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

C++: 
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
Genişletmek için tıkla ...
Ç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
 
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 www.excel.web.tr
 
Korhan Ayhan' Alıntı:
Deneyiniz.

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

C++: 
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
Genişletmek için tıkla ...
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.
 
Önerdiğim kullanıcı tanımlı fonksiyonu excelin yerleşik fonksiyonları gibi kullanabilirsiniz. Kurguda hata yoksa sonuç üretmesi gerekir.
 
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.
 
Korhan Ayhan' Alıntı:
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.
Genişletmek için tıkla ...
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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst