Düşeyara TopluSonuç (Virgülle Ayrılmış)

[leonadies]

Üstadlar Merhaba;

K:L sütununda bilgiler var. S2 hücresine veri girdiğimde düşeyara mantığında denk gelen bilgileri arasına virgül atarak T2 hücresine yazsın istiyorum. Yalnız makro yardımıyla olmalı.Mümkün müdür?

Dosyalarım ekte

 

[Muzaffer Ali]

Merhaba.
Sayfanın kod kısmına aşağıdaki kodu kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bak As Long
    Dim Detay As String
    If Not Intersect(Target, Range("S2")) Is Nothing Then
        For Bak = 1 To Cells(Rows.Count, "K").End(xlUp).Row
            If Cells(Bak, "K") = Target Then
                If Not Detay = "" Then Detay = Detay & ","
                Detay = Detay & Cells(Bak, "L")
            End If
        Next
        If Detay = "" Then
            Cells(2, "T") = "Bulunamadı."
        Else
            Cells(2, "T") = Detay
        End If
    End If
End Sub

 

[Korhan Ayhan]

Alternatif;

KTF;

Kullanım şekli;

=DÜŞEYARA_BİRLEŞTİR(K2:L35;S2;",")

Option Explicit

Function DÜŞEYARA_BİRLEŞTİR(Alan As Range, Kriter As Range, Optional Ayıraç As String = ",") As String
    Dim X As Long
    
    Application.Volatile True
    
    For X = LBound(Alan.Value, 1) To UBound(Alan.Value, 1)
        If Alan.Cells(X, 1) = Kriter.Value Then
            If DÜŞEYARA_BİRLEŞTİR = "" Then
                DÜŞEYARA_BİRLEŞTİR = Alan.Cells(X, 2)
            Else
                DÜŞEYARA_BİRLEŞTİR = DÜŞEYARA_BİRLEŞTİR & Ayıraç & Alan.Cells(X, 2)
            End If
        End If
    Next
End Function

 

[leonadies]

@Muzaffer Ali Hocam teşekkür ederim

 

[Muzaffer Ali]

Rica ederim. Kolay gelsin.

 

[leonadies]

@Korhan Ayhan hocam çok teşekürler KFT de çok güzel.
Ben bu kodunuzu seri olarak S:S sütununa uygulamak istedim ancak çok kasıyor. Yani S:S alt alta veri gireceğim. Başka bir çözümü olur mu?

 

[Korhan Ayhan]

Dinamik alan tanımlayıp kullanabilirsiniz.

 

[leonadies]

KTF niz ile mi ? Nasıl yapacağım? Birde kasılması gider mi öyle yapınca? @Korhan Ayhan

 

[Korhan Ayhan]

Kullandığınız şekli ile örnek dosya ekleyin. Bakalım hızlandırabilir miyiz.

 

[leonadies]

KTF niz ile çözüm sağladım Korhan Hocam. Sorun excelimde imiş. Tekrar teşekkürler

 

[leonadies]

Yine bu konuya ihtiyacım oldu. S:S sutununa girdiğim değerleri buton ile yatırmam lazım. Yani seri şekilde aşağıya doğru kendisi yapmalı. KTF dışında çözüme ihtiyacım var şuan

 

[Ziynettin]

Sub test()
Sheets("Verilerim").Select
son = Range("K" & Rows.Count).End(3).Row
If son < 2 Then Exit Sub
Set dc = CreateObject("scripting.dictionary")
a = Range("K1:L" & son).Value
    For i = 2 To UBound(a)
        ww = CStr(a(i, 1))
        If Not dc.exists(ww) Then
            dc(ww) = a(i, 2)
        Else
            dc(ww) = dc(ww) & ", " & a(i, 2)
        End If
    Next i
    
son = 0
Erase a

son = Range("S" & Rows.Count).End(3).Row
If son < 2 Then Exit Sub
a = Range("S1:S" & son).Value
ReDim b(1 To UBound(a), 1 To 1)
    For i = 2 To UBound(a)
        ww = CStr(a(i, 1))
        If dc.exists(ww) Then
            b(i - 1, 1) = dc(ww)
        End If
    Next i
    
[T2].Resize(UBound(a) - 1) = b
MsgBox "İşlem tamam...", vbInformation
End Sub

 

[Korhan Ayhan]

Alternatif olsun;

Option Explicit

Sub Detay_Listele()
    Dim Veri As Variant, Son As Long, X As Long
    Dim Kriter As Range, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Son = Cells(Rows.Count, "K").End(3).Row
    If Son < 3 Then Son = 3
    
    Veri = Range("K2:L" & Son).Value
    
    Range("T2:T" & Rows.Count).ClearContents
    
    ReDim Liste(1 To Son, 1 To 1)
    
    With CreateObject("Scripting.Dictionary")
        For Each Kriter In Range("S2:S" & Cells(Rows.Count, "S").End(3).Row)
            For X = LBound(Veri, 1) To UBound(Veri, 1)
                If Veri(X, 1) = Kriter.Value Then
                    If Not .Exists(Veri(X, 1)) Then
                        Say = Say + 1
                        .Add Veri(X, 1), Say
                        Liste(Say, 1) = Veri(X, 2)
                    Else
                        Liste(.Item(Veri(X, 1)), 1) = Liste(.Item(Veri(X, 1)), 1) & "," & Veri(X, 2)
                    End If
                End If
            Next
        Next
    End With

    If Say > 0 Then
        Range("T2").Resize(Say) = Liste
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If
End Sub

 

[leonadies]

@Ziynettin üstadım ellerine sağlık Teşekkür ederim

 

[leonadies]

@Korhan Ayhan Sizede teşekkür ederim

 

[Korhan Ayhan]

Bu da KTF ile döngü uygulaması;

Option Explicit

Function DÜŞEYARA_BİRLEŞTİR(ByVal Alan As Variant, ByVal Kriter As Variant, Optional Ayıraç As String = ",") As String
    Dim X As Long
    
    Application.Volatile True
    
    For X = LBound(Alan.Value, 1) To UBound(Alan.Value, 1)
        If Alan.Cells(X, 1) = Kriter Then
            If DÜŞEYARA_BİRLEŞTİR = "" Then
                DÜŞEYARA_BİRLEŞTİR = Alan.Cells(X, 2)
            Else
                DÜŞEYARA_BİRLEŞTİR = DÜŞEYARA_BİRLEŞTİR & Ayıraç & Alan.Cells(X, 2)
            End If
        End If
    Next
End Function

Sub Detay_Listele()
    Dim Veri As Range, Son As Long, Zaman As Double
    
    Zaman = Timer
    
    Son = Cells(Rows.Count, "S").End(3).Row
    
    Range("T2:T" & Rows.Count).ClearContents
    
    For Each Veri In Range("S2:S" & Son)
        Veri.Offset(, 1) = DÜŞEYARA_BİRLEŞTİR(Range("K2:L" & Cells(Rows.Count, "K").End(3).Row), Veri.Value, ",")
    Next

    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[leonadies]

Verilerim (Sayfa1) sekmesi aktif olmadığında nasıl bir düzenleme yapmam gerekiyor?_
Örneğin Sayfa2 de iken bu makro arka planda halletsin istiyorum
@Korhan Ayhan @Ziynettin