Rastgele ve Eşit dağıtım

[hasankardas]

Daha önce siteden indirdiğim bir uygulamayı uyarlamaya çalıştım istediğim gibi olmadı. Elimde 5000 satırlık bir veri var bunu belirlerdiğim sayıda gruba eşit dağıtmak istiyorum. her dağıtılan grup yeni bir sayfada olacak,

Yardımlarınız için teşekkür ederim.

 

[Asri]

Daha önce siteden indirdiğim bir uygulamayı uyarlamaya çalıştım istediğim gibi olmadı. Elimde 5000 satırlık bir veri var bunu belirlerdiğim sayıda gruba eşit dağıtmak istiyorum. her dağıtılan grup yeni bir sayfada olacak,

Yardımlarınız için teşekkür ederim.

* Dağıtım sırasında bir kriteriniz var mı?
* 10 grup olduğunda 5000/10= 500 her grupda 500 kişi mi olacak?
* Eşit dağılmayınca fazla yada eksik ilk grup da mı olacak son grup da mı?
* Tüm listedeki F kolonu ile şablodaki F kolonu aynı içeriğe mi sahip?

 

[hasankardas]

* Dağıtım sırasında bir kriteriniz var mı?
* 10 grup olduğunda 5000/10= 500 her grupda 500 kişi mi olacak?
* Eşit dağılmayınca fazla yada eksik ilk grup da mı olacak son grup da mı?
* Tüm listedeki F kolonu ile şablodaki F kolonu aynı içeriğe mi sahip?

Asri hocam ilginiz için teşekkürler.
*belirlenen grup sayısına bölecek lakin 500 olur 501 olur 499 olur önemli değil.
*fazlalık olan değerin hangi gruba gittiği önemli değil.
*evet f kolonu aynı içeriğe sahip yazmayı unutmuşum.

teşekkürler

 

[Asri]

Kontrol ediniz.

Sub dagit()
   Sheets("tüm liste").Select
   Application.DisplayAlerts = False
   kacgrup = 0 + Range("H2").Value
   For i = Sheets.Count To 1 Step -1
     If InStr(Sheets(i).Name, "Grup") > 0 Then
        Sheets(i).Delete
     End If
   Next i
   
   Sheets("tüm liste").Select
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   adet = Int(sonsatir / kacgrup)
   grupsay = 0
   For i = 2 To sonsatir Step adet
     grupsay = grupsay + 1
     If grupsay > kacgrup Then
        grupsay = grupsay - 1
        Sheets(grupsay & ". Grup").Select
        sonsatirg = Cells(Rows.Count, "B").End(3).Row + 1
        Sheets("tüm liste").Select
        Range("A" & i & ":F" & i + adet - 1).Copy
        Sheets(grupsay & ". Grup").Range("A" & sonsatirg).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        
        Exit For
     End If
     Sheets("Şablon").Select
     Sheets("Şablon").Copy After:=Sheets(Sheets.Count)
     ActiveSheet.Name = grupsay & ". Grup"
     Cells(1, 1).Select
     ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'tüm liste'!A1", TextToDisplay:="Tüm Liste"
     Sheets("tüm liste").Select
     Range("A" & i & ":F" & i + adet - 1).Copy
     Sheets(grupsay & ". Grup").Range("A9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
     Sheets(grupsay & ". Grup").Select
     Cells(1, 1).Select
   Next i
End Sub

 

[hasankardas]

Kontrol ediniz.

Sub dagit()
   Sheets("tüm liste").Select
   Application.DisplayAlerts = False
   kacgrup = 0 + Range("H2").Value
   For i = Sheets.Count To 1 Step -1
     If InStr(Sheets(i).Name, "Grup") > 0 Then
        Sheets(i).Delete
     End If
   Next i
   
   Sheets("tüm liste").Select
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   adet = Int(sonsatir / kacgrup)
   grupsay = 0
   For i = 2 To sonsatir Step adet
     grupsay = grupsay + 1
     Sheets("Şablon").Select
     Sheets("Şablon").Copy After:=Sheets(Sheets.Count)
     ActiveSheet.Name = grupsay & ". Grup"
     Cells(1, 1).Select
     ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'tüm liste'!A1", TextToDisplay:="Tüm Liste"
     Sheets("tüm liste").Select
     Range("A" & i & ":F" & i + adet - 1).Copy
     Sheets(grupsay & ". Grup").Range("A9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
     Sheets(grupsay & ". Grup").Select
     Cells(1, 1).Select
   Next i
End Sub

Hocam yardımınız için teşekkür ederim.örneğin 520 satırlık bir dağıtım yaptığımda grup sayısını 9 yaptığımda her gruba 55 dağıtım yapıyor kalan 5 kişiyi 10. grup olarak oluşturuyor

 

[Asri]

Kod güncellendi.

Kontrol ediniz.