a sütunundaki verileri b ve c sütünuna aktarma

[maxcilopez]

Merhaba arkadaşlar
Yapmak istediğim a sutununda 1000 adet verim var
ben bu verileri b ve c sutununda belli bir kurala göre kopyalamak istiyorum
Örneğin aşağıda 18 adet veri var ilk 5 veriyi b sutununa yazdı daha sonra sonraki 5 veriyi c sutununa yazdı daha sonra sonraki 5 veriyi b sutununda kaldığı yerden yazdı daha sonra sonraki veriyi c sutununda kaldığı yerden yazdı
ben burada 18 adet veriyi 5 şerli adet olarak yazdım ama 1000 adet verimi 50 şer olarak yazdıracağım. Tesekürler
a b c
1 1 6
2 2 7
3 3 8
4 4 9
5 5 10
6 11 16
7 12 17
8 13 18
9 14
10 15
11
12
13
14
15
16
17
18

 

[PLİNT]

Merhaba
Verilerinizin "A2" hücresinden itbaren olduğunu varsayarak:

[SIZE="2"]Sub parça()
Dim s1 As Worksheet
Dim s, x, a As Integer
Set s1 = Sheets("Sayfa1")
s = 1: x = 1
For a = 1 To 1000
If Right(a, 2) <= 50 And Right(a, 2) > 0 Then
s = s + 1
s1.Cells(s, 2) = s1.Cells(a + 1, 1)
Else
x = x + 1
s1.Cells(x, 3) = s1.Cells(a + 1, 1)
End If
Next
End Sub[/SIZE]

 

[Necdet]

Merhaba,

Alternatif olsun.
Adet = 5 yerine satırındca 5 değerini gerçekte kaç satır aktaracaksanız o değeri veriniz.

Sub Aktar()

    Dim Adet    As Integer, _
        i       As Long, _
        j       As Long, _
        Kol     As Integer
    
    Adet = 5
    Kol = 2
    j = 2
    Application.ScreenUpdating = False
    
    For i = 2 To Cells(Rows.Count, "A").End(3).Row Step Adet
        Range("A" & i & ":A" & i + Adet - 1).Copy Cells(j, Kol)
        Kol = Kol + 1
        If Kol > 3 Then
            Kol = 2
            j = j + Adet
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamlanmıştır....", vbInformation
    
End Sub

 

[maxcilopez]

İkinizden de Allah razı olsun