Bir sütunda benzer verilere ait saıtr karşılıklarının yan yana yazılması

[u.L.a.s]

Merhabalar

aşağıdaki resimde göründüğü gibi A sütununda bazı veriler vardır. bir çoğu belli yerlerde tekrarlayan verilerdir. Ama her verinin karşılığındaki satırlarda yani B ve C sütununa karşılık gelen hücrelerde farklı veriler mevcuttur.

Ben bu A sütunundaki benzer verileri tek bir veri yapıp karşısındaki satırda bulunan her veriyi B C D E F G şeklinde hücre içeriklerine yazsın istiyorum.
Aşağıdaki gibi

Bilgi ve yardımlarınızı rica ederim

Teşekkürler

 

[Ziynettin]

Merhaba,

Deneyiniz..

Option Explicit
Sub benzersiz_liste()
Dim a(), c, d As Object, Kriter
Dim i As Long, Satir As Long
Set d = CreateObject("Scripting.Dictionary")
a = Range("A2:C" & Cells(Rows.Count, 1).End(3).Row)

    For i = 1 To UBound(a)
        d(a(i, 1)) = d(a(i, 1)) & a(i, 2) & "#" & a(i, 3) & "#"
    Next i
    
    Range("A1:C" & Rows.Count).ClearContents
    
    Satir = 2
    Cells(Satir - 1, "A") = "Ad"
    For Each c In d.keys
        Kriter = Split(d(c), "#")
        Cells(Satir, "A") = c
        Cells(Satir, "B").Resize(, UBound(Kriter)) = Kriter
        Satir = Satir + 1
    Next c
    Range("B1").Resize(1, UBound(Kriter)) = "Veri"
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[Orion1]

Dosyanız linktedir.

DOSYAYI İNDİR

Sub aktar59()
Dim sh As Worksheet, sonsat As Long, z As Object, sut As Integer
Dim vkey, liste(), deg, j As Integer, sat As Long
Set sh = Sheets("Sayfa2")
sh.Range("A2:XFC" & Rows.Count).ClearContents
Sheets("Sayfa1").Select
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
liste = Range("A2:C" & sonsat).Value
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        z.Add liste(i, 1), liste(i, 2) & "|" & liste(i, 3)
    Else
        z.Item(liste(i, 1)) = z.Item(liste(i, 1)) & "|" & liste(i, 2) & "|" & liste(i, 3)
    End If
Next i
Erase liste
sat = 1
Application.ScreenUpdating = False
For Each vkey In z.keys
    deg = Split(z.Item(vkey), "|")
    sut = 2
    sat = sat + 1
    sh.Cells(sat, "A").Value = vkey
    For j = 0 To UBound(deg)
        sh.Cells(sat, sut).Value = deg(j)
        sut = sut + 1
    Next j
Next vkey
sh.Select
Set z = Nothing
Set sh = Nothing
Application.ScreenUpdating = True
MsgBox "Bitti." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[u.L.a.s]

Çok teşekkürler üstadım

 

[Orion1]

Çok teşekkürler üstadım

Rica ederim.
İyi çalışmalar.