sütun değerine aktarma

[igultekin2000]

iyi günler;
B sütunundaki fiş numarasına göre borç-alacak-ve hesap kod' kısmanda olan değerleri yan sütunlara aktarmak istiyorum. Makro veya formül olarak, benzer makrolar üzerinde deneme yaptım ama yapamadım. Örnek dosya ve resimleri ekledim, Teşekkürler.
Daha önce A sütununa göre b ve c' deki değerleri yan yana getiriyordum. ama şimdiki daha karmaşık olduğu için kod üzerinde düzenleme yapamadım.

Sub test()
On Error Resume Next
    a = Range("A2:C" & Cells(Rows.Count, 1).End(3).Row).Value
    pas = 3
    ReDim b(1 To UBound(a) / pas, 1 To 5)
        For i = 1 To UBound(a) Step pas
            say = say + 1
            b(say, 1) = a(i, 1)
            b(say, 2) = a(i, 2)
            For y = 0 To 2
                b(say, y + 3) = a(i + y, 3)
            Next y
        Next i
    [F2].Resize(say, 5) = b
End Sub

 

[igultekin2000]

Option Explicit
Sub yan_sutunlara()
Dim a(), b(), c(), tbl(), d As Object, d1 As Object, deg As Variant
Dim i As Long, j As Byte, Say As Long, Sut_Liste(), Sut As Byte, s As Double
Sheets("Sayfa1").Activate
Application.ScreenUpdating = 0
s = TimeValue(Now)

Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
a = Range("A2:B" & Cells(Rows.Count, 1).End(3).Row)

ReDim b(1 To UBound(a), 1 To 3)
    For i = 1 To UBound(a)
        If Not d.exists(a(i, 1)) Then
            Say = Say + 1
            d(a(i, 1)) = Say
            b(Say, 1) = a(i, 1)
        End If
        b(d(a(i, 1)), 2) = b(d(a(i, 1)), 2) & "|" & a(i, 2)
        b(d(a(i, 1)), 3) = b(d(a(i, 1)), 3) + 1
    Next i
    
tbl = Array(b)
    For i = 1 To d.Count
    deg = (tbl(0)(i, 3))
        If Not d1.exists(deg) Then
            d1(deg) = tbl(0)(i, 3)
        End If
    Next i
Sut_Liste = d1.keys
Sut = Application.Max(Sut_Liste)
ReDim c(1 To d.Count, 1 To Sut + 1)
Say = 0
    For i = 1 To d.Count
        Say = Say + 1
        c(Say, 1) = tbl(0)(i, 1)
        deg = Split(tbl(0)(i, 2), "|")
        For j = 1 To UBound(deg)
            c(Say, j + 1) = deg(j)
        Next j
    Next i
With Sheets("Sayfa2")
.Cells.ClearContents
.[A2].Resize(d.Count, Sut + 1).NumberFormat = "@"
.[A2].Resize(d.Count, Sut + 1) = c
.Cells.EntireColumn.AutoFit
.Select
End With
Application.ScreenUpdating = 1
MsgBox "İşleminiz tamamlandı..." & vbLf & vbLf & _
    CDate(TimeValue(Now) - s), vbInformation
End Sub

forumda örnek buldum A sütunundaki değere göre B sütunundaki değerleri yan sütuna getiriyor, Makroyu B-C-D olarak güncellemek mümkün olabilir midir.