yan yana satırları alt alta stuna dönüştürmek istiyorum ve artan satır kadar boşluk eklemek

[huseyinbrk]

xxxx 1 2 3 4 5 6
xxxx
xxxx
xxxx
yyyy
yyyy

xxxx 1
xxxx 2
xxxx 3
xxxx 4
5
6
yyyy
yyyy
yyyy
yyyy
elimden geldiğince anlatmaya çalıştım 1 2 3 .. yazan kısımlarda ürün görselleri var bunları dikey stun haline getirdiğimde yy koleksiyonuna geliyor. yardıma ihtiyacım olan nokta bu satırları dikey stun haline getirince xxx ve yyy koleksiyonları arasında boşluk bırakan bir makro. şimdiden çok teşekkür ederim.

 

[veyselemre]

Sub test()
    Application.ScreenUpdating = False
    Dim sSat&, say&, rng As Range, r As Range, urun$, sSut&, i&, h
    sSat = Cells(Rows.Count, 8).End(3).Row
    say = WorksheetFunction.CountA(Range("H2:H" & sSat))
    If say = 0 Then Exit Sub
    Set rng = Range("H2:H" & sSat).SpecialCells(xlCellTypeConstants)
    For Each r In rng
        urun = Cells(r.Row, 1).Value
        sSut = Cells(r.Row, Columns.Count).End(xlToLeft).Column - 7
        If sSut > 1 Then
            say = 0
            For i = 1 To sSut
                Set h = Cells(r.Row, i + 8)
                If h.Value <> "" Then
                    say = say + 1
                    If Cells(r.Row + say, 1).Value <> urun Then
                        Rows(r.Row + say).Insert
                    End If
                    Cells(r.Row + say, 8).Value = h.Value
                    h.ClearContents
                End If
            Next i
        End If
    Next r
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam", vbInformation
End Sub

 

[huseyinbrk]

elinize sağlık Veysel Bey kod doğru çalışıyor sadece 1den 8e kadar stunları seçip çalıştır dediğimde bir soldaki barkod sütununun üstüne geliyor urller o stunda karışıklık oluyor. alt alta sıralamayı 1 yazan stunda yapabilir miyiz?

 

[veyselemre]

Sub test()
    Application.ScreenUpdating = False
    Dim sSat&, say&, rng As Range, r As Range, urun$, sSut&, i&, h
    sSat = Cells(Rows.Count, 9).End(3).Row
    say = WorksheetFunction.CountA(Range("I2:I" & sSat))
    If say = 0 Then Exit Sub
    Set rng = Range("I2:I" & sSat).SpecialCells(xlCellTypeConstants)
    For Each r In rng
        urun = Cells(r.Row, 1).Value
        sSut = Cells(r.Row, Columns.Count).End(xlToLeft).Column - 8
        If sSut > 1 Then
            say = 0
            For i = 1 To sSut
                Set h = Cells(r.Row, i + 9)
                If h.Value <> "" Then
                    say = say + 1
                    If Cells(r.Row + say, 1).Value <> urun Then
                        Rows(r.Row + say).Insert
                    End If
                    Cells(r.Row + say, 9).Value = h.Value
                    h.ClearContents
                End If
            Next i
        End If
    Next r
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamam", vbInformation
End Sub

 

[huseyinbrk]

teşekkürler elinize sağlık.