Rastgele nöbet yaz makrosu (YARDIM)

[TanerSaydam]

Merhaba arkadaşlar;

Sayfa1'de B sütuna yazacağım personelleri, eğer C sütunu 0'da büyükse seçerek I6'dan başlayarak bir tablo oluşturuyorum.

Yapmak istediğim 24 saatlik nöbet vardiyası var. Bunun için de nöbet tutulan yerler var. Ben bir makro ile bu tabloyu oluşturuyorum Tablo'da I sütunun da Personel adı, Hemen başında da saatler var. Tuşa bastığımda otomatik olarak bu personele Nöbet Yeri tanımlamasını istiyorum. Hiçbir nöbet yeri boş kalmayacak şekilde ve çakışmayacak şekilde olmalı.

Örnek dosya ektedir. Yardımlarınızı bekliyorum, şimdiden herkese teşekkürler.

https://www.dosyaupload.com/5a1q

 

[Asri]

Merhaba arkadaşlar;

Sayfa1'de B sütuna yazacağım personelleri, eğer C sütunu 0'da büyükse seçerek I6'dan başlayarak bir tablo oluşturuyorum.

Yapmak istediğim 24 saatlik nöbet vardiyası var. Bunun için de nöbet tutulan yerler var. Ben bir makro ile bu tabloyu oluşturuyorum Tablo'da I sütunun da Personel adı, Hemen başında da saatler var. Tuşa bastığımda otomatik olarak bu personele Nöbet Yeri tanımlamasını istiyorum. Hiçbir nöbet yeri boş kalmayacak şekilde ve çakışmayacak şekilde olmalı.

Örnek dosya ektedir. Yardımlarınızı bekliyorum, şimdiden herkese teşekkürler.

https://www.dosyaupload.com/5a1q

9 Personel, 10 Nöbet yeri ve 12 farklı nöber saati var.

Eşit bir dağılım yapılamaz gibi geliyor.
Siz sayfa 2 ye örnek bir sonuç yazar mısınız?

Tabloda , Personel sayısı, Nöbet yerleri ve nöbet saati sayısı sabit mi?

 

[YUSUF44]

Ekteki dosyayı inceleyiniz:

https://drive.google.com/file/d/1cJraoP4fg6n4WDRXWuY2UYOqLpXYvspm/view?usp=sharing

 

[halit3]

İstediğiniz gibi olmaya bilir bu kodu bir dene her aktarmada farklı sütunlara aktarım yapıyor.

not: örnek dosyanızda deneme sayfasında C sütununa denemek amacı ile hepsini 3 yapın kişi başına üç defa aktarım yapacaktır.

Sub aktar()


Dim say5 As Long


sutekle = 7
bas = 1
bas2 = 5
sut = 2
sat = bas2

mak = Cells(Rows.Count, sut).End(3).Row

For i = bas + 1 To mak
sayi = sayi + 1
Next

son2 = 9 'WorksheetFunction.CountA(Range(Cells(bas + 1, sut), Cells(mak, sut)))
son = Application.InputBox("Sayı giriniz.", "Maksinum sayı", son2, 400, 30, , Type:=1)
If son = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If


Set Sh = Sheets(ActiveSheet.Name)

If WorksheetFunction.CountA(Sh.Cells) > 0 Then
topsat = Sh.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
topsut = Sh.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Else
Exit Sub
End If

Columns("D:H").ClearContents
Range(Cells(bas2 + 1, sut + sutekle), Cells(topsat, topsut)).ClearContents
For n = 1 To 100
say5 = 0
sut = 2
sat = bas2


sut2 = Worksheets(ActiveSheet.Name).Cells(bas2 + 1, Columns.Count).End(xlToLeft).Column + 1
If sut2 <= sut + sutekle Then sut2 = sut + sutekle

mak3 = WorksheetFunction.CountA(Range(Cells(bas + 1, sut), Cells(mak, sut)))

son1 = 0
mak2 = WorksheetFunction.CountA(Range(Cells(bas + 1, sut + 4), Cells(mak, sut + 4)))

If mak - bas = mak2 Then
Range(Cells(bas, sut + 3), Cells(mak, sut + 4)).ClearContents
End If

det1 = WorksheetFunction.Sum(Range(Cells(bas + 1, sut + 1), Cells(mak, sut + 1)))
det2 = WorksheetFunction.Sum(Range(Cells(bas + 1, sut + 2), Cells(mak, sut + 2)))
If det1 = det2 Then
Range(Cells(bas, sut + 3), Cells(mak, sut + 4)).ClearContents
GoTo atla3
End If


For k = 1 To 5

ReDim sayilar(sayi)
Dim Satir As Integer

Range(Cells(bas, sut + 3), Cells(mak, sut + 3)).ClearContents
mak2 = WorksheetFunction.CountA(Range(Cells(bas + 1, sut + 4), Cells(mak, sut + 4)))

For j = 1 To sayi

If Cells(j + bas, sut + 1) > Cells(j + bas, sut + 2) Then

atla:

say5 = say5 + 1

If say5 > 50 Then
Range(Cells(bas, sut + 4), Cells(mak, sut + 4)).ClearContents
GoTo atla3
End If


Randomize
Satir = Int((Rnd * sayi) + 1)

For m = 1 To sayi
If Satir = sayilar(m) Then
GoTo atla
End If
Next

If Cells(Satir + bas, sut + 1) = Cells(Satir + bas, sut + 2) Then
GoTo atla
End If

If Cells(Satir + bas, sut + 4) <> "" Then
GoTo atla
End If




say5 = 0
Cells(Satir + bas, sut + 2) = Cells(Satir + bas, sut + 2) + 1
sayilar(j) = Satir

Cells(Satir + bas, sut + 3) = Satir

sat = sat + 1
Cells(sat, sut2) = Cells(Satir + bas, sut)
Cells(Satir + bas, sut + 4) = Cells(sat, sut2)
mak2 = WorksheetFunction.CountA(Range(Cells(bas + 1, sut + 4), Cells(mak, sut + 4)))
det1 = WorksheetFunction.Sum(Range(Cells(bas + 1, sut + 1), Cells(mak, sut + 1)))
det2 = WorksheetFunction.Sum(Range(Cells(bas + 1, sut + 2), Cells(mak, sut + 2)))
If det1 = det2 Then
GoTo atla3
End If

If mak - bas = mak2 Then
Range(Cells(bas, sut + 4), Cells(mak, sut + 4)).ClearContents
End If

son1 = son1 + 1
If son1 = son Then GoTo atla3
End If

Next j

Next k

atla3:
mak2 = WorksheetFunction.CountA(Range(Cells(bas + 1, sut + 4), Cells(mak, sut + 4)))
If mak - bas = mak2 Then
Range(Cells(bas, sut + 3), Cells(mak, sut + 4)).ClearContents
GoTo atla4
End If



Next n
atla4:

MsgBox "işlem tamam"
End Sub

 

[4yaKuza]

Ekteki dosyayı inceleyiniz:

https://drive.google.com/file/d/1cJraoP4fg6n4WDRXWuY2UYOqLpXYvspm/view?usp=sharing

Çok guzelmıs askerdeyken bana lazımdı artık geçti ama genede aldım elim altında bulunsun