Tablodan veri toplama

[harpoon_1903]

Merhaba,
Düşeyara ile yapmaya çalıştım ama beceremedim. Tablodaki verileri ara sütuna göre düzenlemem gerekiyor. Örnek dosyaya bakarsanız sevinirim. Şimdiden teşekkürler...

 

[Orion1]

SÜZ butonuna basınız.
Ekli dosyayı inceleyiniz.

Sub suz()
Dim c As Range, a As Long
Sheets("Sayfa1").Select
Range("H3:M65536").ClearContents
isim = InputBox("Aranacak Olan İsimi Giriniz..!!", ARA_BUL)
If isim = "" Then Exit Sub
Set c = Range("C1:C65536").Find(isim, , xlValues, xlWhole, , 1)
ReDim myarr(1 To 6, 1 To 1)
If Not c Is Nothing Then
    ilkadres = c.Address
    Do
    a = a + 1
    ReDim Preserve myarr(1 To 6, 1 To a)
    myarr(1, a) = isim
    myarr(2, a) = Cells(c.Row, 1)
    myarr(3, a) = Cells(c.Row, 2)
    myarr(4, a) = Cells(c.Row, 4)
    myarr(5, a) = Cells(c.Row, 5)
    myarr(6, a) = Cells(c.Row, 6)
    Set c = Range("C2:C65536").FindNext(c)
    Loop While ilkadres <> c.Address And Not c Is Nothing
End If
If a = 0 Then Exit Sub
[H3].Resize(a, 6) = Application.Transpose(myarr)
MsgBox "İşlem Tamam..!!", vbOKOnly + vbInformation, "AKTARMA"
End Sub

 

[harpoon_1903]

Merhaba sayın Orion2,
Hızlı ve mükemmel bir yanıt. Çok teşekkür ederim. İyi akşamlar...

 

[Orion1]

Merhaba sayın Orion2,
Hızlı ve mükemmel bir yanıt. Çok teşekkür ederim. İyi akşamlar...

Rica ederim.
İyi akşamlar.