Soru Aynı verileri yanyana sıralama

[by_erman]

Aşağıdaki kodda sayfa1 in A sütunun da bulunan benzer verileri tarayıp sayfa2 de benzerden tek olanı hücreye yazıp sayfa 1 de c sütununda ki benzerler verileri yanyana sıralıyor. Fakat ben aynı şekilde sayfa1 de bulunan b hücresinde ve c hücresindeki verileri de Sayfa2 de tek hücreye basmak istiyorum. Kodda ufak bir yardım rica edebilirmiyim?

Sub KOD()
    Application.ScreenUpdating = False
    Dim SD As Worksheet: Set SD = Sheets("Sayfa1")
    Dim SO As Worksheet: Set SO = Sheets("Sayfa2")
    Dim liste(), dizi()

    son = SD.Cells(Rows.Count, "A").End(3).Row
    SD.Range("A2:B" & son).Sort SD.Range("A2"), xlAscending
    liste = SD.Range("A1:B" & son).Value
    Set dic = CreateObject("scripting.dictionary")

    For x = 1 To UBound(liste, 1)
        aranan = liste(x, 1)
        If Not dic.exists(aranan) Then
            dic.Add aranan, ""
        End If

    Next x

    SO.Cells.ClearContents
    SO.Range("A1").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
    SO.Range("B1") = "TEST"

    For i = 2 To SO.Cells(Rows.Count, "A").End(3).Row
        ilk = WorksheetFunction.Match(SO.Cells(i, "A"), SD.Range("A:A"), 0)
        son = WorksheetFunction.CountIf(SD.Range("A:A"), SO.Cells(i, "A")) + ilk - 1

        SD.Range("C" & ilk & ":C" & son).Copy
        SO.Cells(i, "C").PasteSpecial _
                Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=True

    Next i
    SO.Cells.EntireColumn.AutoFit
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox " B i t t i"
End Sub