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

Katılım
27 Mart 2019
Mesajlar
37
Excel Vers. ve Dili
2013 türkçe
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.

 
Katılım
6 Temmuz 2015
Mesajlar
782
Excel Vers. ve Dili
2003
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
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
2,741
Excel Vers. ve Dili
Excel 2010-TR (32 bit)
Alternatif;
Kod:
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
 
Katılım
27 Mart 2019
Mesajlar
37
Excel Vers. ve Dili
2013 türkçe
Saban hocam en sona virgül koymamasını nasıl sağlarız?
Veyselemre bey teşekkür ederim.
 
Katılım
6 Temmuz 2015
Mesajlar
782
Excel Vers. ve Dili
2003
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
 

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
29,328
Excel Vers. ve Dili
OFFICE 2019 PRO TR
Alternatif,

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

C++:
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
 
Katılım
27 Mart 2019
Mesajlar
37
Excel Vers. ve Dili
2013 türkçe
İlginiz için teşekkür ederim Korhan bey.
 
Üst