Alt alta sıralama

[hassas]

Sayın Arkadaşlar öncelikle iyi günler diler tüm hayatınızda kolaylıklar dilerim.
Ek teki örnek dosyanın içinde gerekli açıklamayı yaptığım bir çalışma dosyam var bu konuda yardımcı olabilirmisiniz.

 

[hamitcan]

Aşağıdaki kodu deneyin.

Sub AltAlta2()
    Dim Arr()
    Dim bb As Long
    c = 1
    b = 2
    bb = 1
    Sheets("SIRALA").[a:b].ClearContents
    With Sheets("Data")
        For Each hcr In .Columns(1).SpecialCells(xlCellTypeBlanks).Cells
            a = a + 1
            ReDim Preserve Arr(1 To a)
            Arr(a) = hcr.Row
        Next
        For t = 1 To UBound(Arr)
            s = Arr(t) - 1
            For j = 1 To SutunSayisi(bb) Step 2
            For i = b To s
                c = c + 1
                Sheets("SIRALA").Cells(c, 1) = .Cells(i, j)
                Sheets("SIRALA").Cells(c, 2) = .Cells(i, j + 1)
            Next
            Next
            b = Arr(t) + 2
            bb = Arr(t) + 1
            s = bb
         Next
    End With
    MsgBox "Bitti"
End Sub
Function SutunSayisi(Sutun As Long)
    SutunSayisi = Sheets("Data").Cells(Sutun, "a").End(xlToRight).Column
End Function

 

[hassas]

Sayın Hamit bey öncelikle iyi akşamlar diler tüm işlerinizde kolaylıklar dilerim.
verdiğiniz kodu ekledim fakat çalıştıramadım.
Yardımcı olabilirseniz sevinirim.

 

[hassas]

Sayın üstadlar yukarıdaki konu ile ilgili yardımlarınızı bekliyorum,
Sayın hamit beyin ekte verdiği kodu uyguladım fakat Data sayfasındaki verileri alt alta sıralama yaptıramadım.

 

[hamitcan]

1.Alt+F11 tuşlarına basın.
2.Insert menüsünden bir Module ekleyin.
3.Kodu içine ekleyin.
4.F5 tuşuna basın.

 

[hassas]

Sayın Hamitcan bey çok teşekkür ederim.
Tüm işlerinizde kolaylıkar dilerim.