Alt alta olan verileri yan yana dizme

[bestercan]

Merhabalar

elimde öğrenci listesi var. Yapmak istediğim şu: 1002 Nolu öğrenciye ait bilgiler sayfa1 de alt alta var. bu bilgileri yan yana "olmasını istediğim" sayfasındaki gibi dizmesini istiyorum.

1002...........
1003..........
1004.........

şeklinde. Yardımcı olursanız sevinirim.

 

[Ferhat Pazarçevirdi]

Aşağıdaki kod işinizi görür sanıyorum. Ekteki dosyayı inceleyiniz.

Option Explicit
Sub Aktar()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim arrNo() As Variant
Dim arrTarih() As Variant
Dim y As Long, x As Long, i As Long, j As Long
Dim sutun As Long
Dim bul As Range, bulSutun As Range
Dim adres As String
Set sh1 = Sheets("Sayfa1")
Set sh2 = Sheets("Sayfa2")
[COLOR=green]'----- BENZERSİZ TARİHLERİN BULUNMASI, SIRALANMASI VE YAZILMASI-----
[/COLOR]sh2.Cells.ClearContents
y = 1
For i = 2 To sh1.Cells(65536, 1).End(xlUp).Row
    If Application.WorksheetFunction.CountIf(sh1.Range("B1:B" & i), sh1.Cells(i, 2)) = 1 Then
       ReDim Preserve arrTarih(1 To y)
       arrTarih(y) = sh1.Cells(i, 2)
       y = y + 1
    End If
Next i
For i = 1 To UBound(arrTarih) - 1
    For j = i + 1 To UBound(arrTarih)
        If arrTarih(i) > arrTarih(j) Then
           x = arrTarih(i)
           arrTarih(i) = arrTarih(j)
           arrTarih(j) = x
        End If
    Next j
Next i
sutun = 2
For i = 1 To UBound(arrTarih)
    sh2.Cells(1, sutun) = arrTarih(i)
    sutun = sutun + 3
Next i
[COLOR=green]'----- BENZERSİZ NOLARIN BULUNMASI, SIRALANMASI VE YAZILMASI ---------
[/COLOR]y = 1
For i = 2 To sh1.Cells(65536, 1).End(xlUp).Row
    If Application.WorksheetFunction.CountIf(sh1.Range("A1:A" & i), sh1.Cells(i, 1)) = 1 Then
       ReDim Preserve arrNo(1 To y)
       arrNo(y) = sh1.Cells(i, 1)
       y = y + 1
    End If
Next i
For i = 1 To UBound(arrNo) - 1
    For j = i + 1 To UBound(arrNo)
        If arrNo(i) > arrNo(j) Then
           x = arrNo(i)
           arrNo(i) = arrNo(j)
           arrNo(j) = x
        End If
    Next j
Next i
For i = 1 To UBound(arrNo)
    sh2.Cells(i + 1, 1) = arrNo(i)
Next i
[COLOR=green]'----- DEĞERLERİN TABLOYA İŞLENMESİ -----------------------[/COLOR]
For i = 2 To sh2.Cells(65536, 1).End(xlUp).Row
     With sh1.Range("a1:a65536")
          Set bul = .Find(sh2.Cells(i, 1), , xlFormulas, xlWhole)
          If Not bul Is Nothing Then
             adres = bul.Address
             Do
                 For j = 1 To UBound(arrTarih)
                     If sh1.Cells(bul.Row, 2) = arrTarih(j) Then: Exit For
                 Next
                 sutun = ((j - 1) * 3) + 2
                 sh2.Cells(i, sutun) = sh1.Cells(bul.Row, 3)
                 sh2.Cells(i, sutun + 1) = sh1.Cells(bul.Row, 4)
                 sh2.Cells(i, sutun + 2) = sh1.Cells(bul.Row, 5)
                 Set bul = .FindNext(bul)
             Loop While Not bul Is Nothing And bul.Address <> adres
          End If
     End With
Next i
sh2.Columns.AutoFit
sh2.Select
Set bul = Nothing
Set sh1 = Nothing
Set sh2 = Nothing
End Sub