mükerrer kaydı sıralama

[mesutaygun70]

İyi günler. Benim oluşturduğum tablo SAYFA1
A B C
1 MESUT ÜÇ
2 ALİ BEŞ
3 MESUT SEKİZ
4 ALİ DÖRT
____________________
SAYFA2 DE OLMASINI İSTEDİĞİM
A B C
1 MESUT ÜÇ, SEKİZ
2 ALİ BEŞ, DÖRT

Yani mükerrer kayıtta araya virgül koyarak birleştirmek istiyorum. Benim yaptığımla sadece ilk kaydı alıyor ikinci kaydı görmüyor. İnşallah anlatabilmişimdir. Teşekkürler.

 

[mesutaygun70]

A....................B..........................C
1 MESUT.............ÜÇ
2 ALİ..................BEŞ
3 MESUT.............SEKİZ
4 ALİ.................. DÖRT

sayfa1
_______________________________________
A........................B..........................C
1 MESUT.............ÜÇ,SEKİZ
2 ALİ..................BEŞ,DÖRT

Sayfa2

 

[Civan Jack]

Örnek dosya ekleyin işi yarı yarıya hızlandırın.

 

[mesutaygun70]

http://s3.dosya.tc/server21/vP5Rwi/YeniMicrosoftExcel_al__maSayfas_.xlsx.html
Ben birleştir formülü ile olması gerekeni yaptım ama bunu ben tek tek seçmeden otomatik olarak almak istiyorum.

 

[bzace]

Merhaba,
Şu KTF işinizi görecektir.
Bir Modülün içerisine yazınız.

Function tüm_veriler(rLookupVal, rTable As Range, lCol As Long)
Dim rCell As Range, Result
    tüm_veriler = CVErr(xlErrNA)
    For Each rCell In rTable
        If rCell = rLookupVal Then
            Result = Result & "," & rCell.Offset(, lCol - 1)
        End If
    Next rCell
    If Result <> "" Then
        Result = Right(Result, Len(Result) - 1)
        tüm_veriler = Result
    End If
End Function

Kullanılışı: =tüm_veriler("mesut ay";veriler!A1:B8;2)

 

[Murat OSMA]

Daha önce sitedeki bir konudan alıntı.

Bu kodları kullanabilirsiniz;

[FONT="Trebuchet MS"]Sub Emre()
    Dim d As Object, i As Long, sut As Integer, sat As Long
    Dim s, a1, a2, t, deg As String, j As Integer
    Set d = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        deg = Cells(i, "A")
        If Not d.exists(deg) Then
            s = Cells(i, "B")
            d.Add deg, s
                Else
           s = d.Item(deg)
           s = s & " " & Cells(i, "B")
           d.Item(deg) = s
       End If
    Next i
    a1 = d.keys: a2 = d.items: sat = 1
    For i = 0 To d.Count - 1
        Cells(sat, "d") = a1(i)
        t = Split(a2(i))
        For j = 0 To UBound(t)
            Cells(sat, 5) = Cells(sat, 5) & " " & t(j)
        Next j
        sat = sat + 1
    Next i
    Application.ScreenUpdating = True
End Sub[/FONT]