Soru Aynı Değere Sahip Hücrelerin Yanındaki Hücreleri Bir Yerde Birleştirme

[serhatyaman43]

Arkadaşlar selam.
Ekteki dosyada A hücresinde bulunan a değeri K hücresinde birden fazla bulunuyor. K hücresindeki a değerlerinin yanındaki hücreleri A hücresindeki a nın yanındaki hücrede aralarına virgül koyarak birleştirmek istiyorum bunu nasıl yapabilirim?
Şimdiden teşekkür ediyorum.

Ornek_Dosya.rar dosyasını indir - download

Ornek_Dosya.rar dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

 

[Saban Sertkaya]

Deneyiniz...

Sub Düğme1_Tıklat()
For a = 1 To [A1048576].End(xlUp).Row
For b = 1 To [K1048576].End(xlUp).Row
If Cells(a, 1) = Cells(b, 11) Then
Cells(a, 2) = Cells(a, 2) & Cells(b, 12) & ","
End If
Next b
Next a
End Sub

 

[serhatyaman43]

Teşekkür ediyorum. Tam istediğim gibi olmuş.

 

[veyselemre]

Alternatif;

Sub test()
    Dim ky, i
    With CreateObject("Scripting.Dictionary")
        For i = 1 To [K1048576].End(xlUp).Row
            ky = Cells(i, "K").Value
            .Item(ky) = .Item(ky) & "," & Cells(i, "L").Value
        Next i
        For i = 1 To [A1048576].End(xlUp).Row
            ky = Cells(i, "A").Value
            If .exiStS(ky) Then Cells(i, "B").Value = Mid(.Item(ky), 2)
        Next i
    End With
End Sub

 

[serhatyaman43]

Saban hocam en sona virgül koymamasını nasıl sağlarız?
Veyselemre bey teşekkür ederim.

 

[Saban Sertkaya]

Merhabalar,

Şu şekilde deneyiniz.

Sub Düğme1_Tıklat()
For a = 1 To [A1048576].End(xlUp).Row
For b = 1 To [K1048576].End(xlUp).Row
If Cells(a, 1) = Cells(b, 11) Then
Cells(a, 2) = Cells(a, 2) & Cells(b, 12) & ","
End If
Next b
Next a
For c = 1 To [B1048576].End(xlUp).Row
d = Len(Cells(c, 2)) - 1
Cells(c, 2) = Mid(Cells(c, 2), 1, d)
Next c
End Sub

 

[serhatyaman43]

Teşekkür ederim Şaban bey.

 

[Saban Sertkaya]

Rica ederim, kolay gelsin.

 

[Korhan Ayhan]

Alternatif,

ADO ile çözüm hazırlanmıştır.

Option Explicit

Sub Duseyara_Birlestir()
    Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String
    Dim Veri As Variant, Son As Long, X As Long, Zaman As Double
      
    Zaman = Timer
  
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
      
    Range("B:B").Clear

    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son = 1 Then Son = 2
    
    Veri = Range("A1:B" & Son).Value
    
    For X = LBound(Veri) To UBound(Veri)
        Sorgu = "Select * From [Sayfa1$K:L] Where F1 = '" & Veri(X, 1) & "'"
        
        Kayit_Seti.Open Sorgu, Baglanti, 1, 1
                        
        If Kayit_Seti.RecordCount > 0 Then
            Veri(X, 2) = Join(Application.Transpose(Application.Transpose(Kayit_Seti.GetRows(, , 1))), ",")
        End If
                        
        If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    Next
    
    If Baglanti.State <> 0 Then Baglanti.Close

    Range("A1").Resize(UBound(Veri, 1), UBound(Veri, 2)) = Veri

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

 

[serhatyaman43]

İlginiz için teşekkür ederim Korhan bey.