listeyi 10 arlı ayırma

[osman.osman]

kolay gelsin sayfa1 de uzayıp giden bir liste var.bu listeyi sayfa2 deki gibi 2 sayfaya 10 'arlı gruplara bölebilirmiyiz.

 

[Necdet]

Merhaba,

Aşağıdaki kodları deneyiniz.

Sub Grupla()

    Dim i   As Long, _
        j   As Long, _
        s1  As Worksheet, _
        s2  As Worksheet
    
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
        
    s2.Cells.Delete
    
    For i = 3 To s1.Cells(Rows.Count, "A").End(3).Row Step 10
        j = s2.Cells(Rows.Count, "A").End(3).Row + 2
        If j = 3 Then j = 1
        s1.Range("A1:H2").Copy s2.Cells(j, "A")
        j = j + 2
        s1.Range("A" & i & ":H" & i + 9).Copy s2.Cells(j, "A")
    Next i
    
    MsgBox "İşlem Tamamdır....", vbInformation, "excel.web.tr"
    
End Sub

 

[YUSUF44]

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz. Verilerinizin çokluğuna göre işlem uzun sürebilir:

Sub aktar()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")

son1 = s1.Cells(Rows.Count, 1).End(3).Row
son2 = s2.Cells(Rows.Count, 1).End(3).Row

s2.Range("A1:H" & son2).ClearContents

For i = 3 To son1 Step 10
yeni = s2.Cells(Rows.Count, 1).End(3).Row + 2
If s2.[a1] = "" Then yeni = 1

s1.Select
[A1:H2].Select
Selection.Copy
s2.Select
Cells(yeni, 1).Select
ActiveSheet.Paste

s1.Select
Range(Cells(i, "A"), Cells(i + 9, "H")).Select
Selection.Copy
s2.Select
Cells(Rows.Count, 1).End(3).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste

Next
s1.Select
[a1].Select
Application.CutCopyMode = False
s2.Select
[a1].Select
MsgBox ("İşlem Tamam :)")
End Sub

 

[osman.osman]

çok teşekkür ediyorum

 

[osman.osman]

birde dağıtım rastgele yapılabirmi

 

[YUSUF44]

Rastgele yapmaktan kastınız nedir?

 

[osman.osman]

listeyi dağıtırken sıraya göre değilde karışık olarak dağıtması

 

[hasankardas]

Çalışma güzel olmuş teşekkürler, burada 10 üzerinden anlatılmış kod üzerinden değişiklik yaparak istediğim sayıda değişime göre yapabiliyorum ancak bunu bir hücreye nasıl bağlayabiliyorum. örneğin L1 hücresine yazdığım sayı kadar dağıtım eşit dağıtacak.

tşklr

 

[YUSUF44]

listeyi dağıtırken sıraya göre değilde karışık olarak dağıtması

Ben yapamam maalesef

 

[YUSUF44]

Çalışma güzel olmuş teşekkürler, burada 10 üzerinden anlatılmış kod üzerinden değişiklik yaparak istediğim sayıda değişime göre yapabiliyorum ancak bunu bir hücreye nasıl bağlayabiliyorum. örneğin L1 hücresine yazdığım sayı kadar dağıtım eşit dağıtacak.

tşklr

L1'de yazan kadar olması için sanıyorum şöyle olur. Kırmızı bölümler değişen yerlerdir:

Sub aktar1()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")

[COLOR="Red"]grup = s1.[L1][/COLOR]

son1 = s1.Cells(Rows.Count, 1).End(3).Row
son2 = s2.Cells(Rows.Count, 1).End(3).Row

s2.Range("A1:H" & son2).ClearContents

For i = 3 To son1 Step [COLOR="red"]grup[/COLOR]
yeni = s2.Cells(Rows.Count, 1).End(3).Row + 2
If s2.[a1] = "" Then yeni = 1

s1.Select
[A1:H2].Select
Selection.Copy
s2.Select
Cells(yeni, 1).Select
ActiveSheet.Paste

s1.Select
Range(Cells(i, "A"), Cells(i + [COLOR="red"]grup - 1[/COLOR], "H")).Select
Selection.Copy
s2.Select
Cells(Rows.Count, 1).End(3).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste

Next
s1.Select
[a1].Select
Application.CutCopyMode = False
s2.Select
[a1].Select
MsgBox ("İşlem Tamam :)")
End Sub