listeden tabloya cevirmek

[voleclub]

Selam karışık listeden tabloya çevirmek istiyorum


[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]

[Orion1]

Dosyanız ektedir.

Kod: [Seç]

Option Explicit
Option Base 1
Sub ogrenci_59()
Dim k As Range, i As Long, myarr(), adr As String, a As Long
Dim j As Byte, isim As String, say As Long, var As Boolean
Dim sat As Long
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Range("G3:I65536").ClearContents
sat = Cells(65536, "B").End(xlUp).Row
If sat < 2 Then Exit Sub
For j = 7 To 9
    isim = Cells(2, j).Value
    Set k = Range("B1:B" & sat).Find(isim, , xlValues, xlWhole)
    If Not k Is Nothing Then
        say = WorksheetFunction.CountIf(Range("B1:B" & sat), isim)
        ReDim myarr(1 To say, 1 To 1)
        adr = k.Address
        Do
            a = a + 1
            myarr(a, 1) = k.Offset(0, -1).Value
            Set k = Range("B1:B" & sat).FindNext(k)
        Loop While Not k Is Nothing And k.Address <> adr
        Cells(3, j).Resize(a, 1) = myarr
        Erase myarr
        var = True
        a = 0
    End If
Next j
Application.ScreenUpdating = True
If var = True Then
    MsgBox "İşlem tamamlandı." & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
End Sub
[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]

[voleclub]

teşekkür ederim bu makrosuzda yapılabilir mi