x leri aktar yardım

[asilme]

arkadaşlar ekli dosyada X ile işaretlediğim sayfa 2 ye aktarılıyor ancak ben 3 isimden sonrasını tekar satır başı yapmak istiyorum mümkünmü.bu dosyayı bu sitede arkadaşlar yaptı ancak ben A4 kağıdına göre 3 lü veya 4 lü gruplar halinde alt alta yazılmasını istiyorum mümkünmü,mümkünse yardımcı olabilirmisiniz.

 

[NBATMAN]

Merhaba,

İlgili Kodlarınızı aşağıdaki gibi değiştiriniz.

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim s1 As Integer
Dim sonsatır As Integer
s1 = ThisWorkbook.Worksheets("Sayfa1").Range("A65536").End(xlUp).Row
sonsatir = 2
    For i = 5 To s1
                 If ThisWorkbook.Worksheets("Sayfa1").Cells(i, "a") = "x" Then
                    Select Case i
                    Case 5
                    ThisWorkbook.Worksheets("Sayfa2").Cells(12, sonsatir) = ThisWorkbook.Worksheets("Sayfa1").Cells(i, "C")
                    ThisWorkbook.Worksheets("Sayfa2").Cells(11, sonsatir) = ThisWorkbook.Worksheets("Sayfa1").Cells(i, "D")
                    sonsatir = sonsatir + 2
                    Case 6
                    ThisWorkbook.Worksheets("Sayfa2").Cells(12, sonsatir) = ThisWorkbook.Worksheets("Sayfa1").Cells(i, "C")
                    ThisWorkbook.Worksheets("Sayfa2").Cells(11, sonsatir) = ThisWorkbook.Worksheets("Sayfa1").Cells(i, "D")
                    sonsatir = sonsatir + 2
                    Case 7
                    ThisWorkbook.Worksheets("Sayfa2").Cells(12, sonsatir) = ThisWorkbook.Worksheets("Sayfa1").Cells(i, "C")
                    ThisWorkbook.Worksheets("Sayfa2").Cells(11, sonsatir) = ThisWorkbook.Worksheets("Sayfa1").Cells(i, "D")
                    sonsatir = sonsatir + 2
                    
                    Case 8
                    sonsatir = 2
                    ThisWorkbook.Worksheets("Sayfa2").Cells(15, sonsatir) = ThisWorkbook.Worksheets("Sayfa1").Cells(i, "C")
                    ThisWorkbook.Worksheets("Sayfa2").Cells(14, sonsatir) = ThisWorkbook.Worksheets("Sayfa1").Cells(i, "D")
                    sonsatir = sonsatir + 2
                    Case 9
                   
                    ThisWorkbook.Worksheets("Sayfa2").Cells(15, sonsatir) = ThisWorkbook.Worksheets("Sayfa1").Cells(i, "C")
                    ThisWorkbook.Worksheets("Sayfa2").Cells(14, sonsatir) = ThisWorkbook.Worksheets("Sayfa1").Cells(i, "D")
                    sonsatir = sonsatir + 2
                    Case 10
                  
                    ThisWorkbook.Worksheets("Sayfa2").Cells(15, sonsatir) = ThisWorkbook.Worksheets("Sayfa1").Cells(i, "C")
                    ThisWorkbook.Worksheets("Sayfa2").Cells(14, sonsatir) = ThisWorkbook.Worksheets("Sayfa1").Cells(i, "D")
                    sonsatir = sonsatir + 2

           
        
                    End Select
                End If
    Next i
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub