Nhờ sắp xếp 64 người vào 8 phòng- trong 7 ngày !

[barney1]

Nhờ các anh, các chị giải quyết giúp em bài này với ạ.
Cho danh sách số người từ số 1 đến số 64 nằm trong khoảng L3:L66
cách để sắp xếp ngẫu nhiên , không lặp lại số 1 đến 64 VÀO trong 8 phòng, và sắp cho 7 ngày
(Là tương ứng là ngày 1, 2,3,4,5,6,7- chú ý Ngày số 1 thì mong muốn sắp xếp cố định như file) .
Thỏa mãn điều kiện : ỨNG VỚI CÁC NGÀY KHÁC NHAU THÌ : TRONG MỘT PHÒNG bất kỳ KHÔNG CÓ >=2 cặp số trùng nhau SO VỚI CÁC NGÀY KHÁC .
Ví dụ ngày 2 ở PHÒNG SỐ 1: có cặp số 58-23 rồi THÌ CÁC NGÀY KHÁC ví dụ Ngày 3 - ở phòng số 1: không được có cặp số 58-23 nữa (xem hình ạ).

Nhờ các bác và anh chị viết giúp code này với ạ!!!


N

 

[VetMini]

NxN thì khá dễ.
Cứ xoay vòng tròn, ngày 2 thì nhóm phòng 2 lên phòng 1, nhóm phòng 3 lên phòng 2,... nhóm phòng 1 qua phòng 8.

Code chính:
a = [C3:J10].Value
For i = 1 To 7
XoayVong a
[C3:J10].Offset(i, 0).Value = a
Next i

Code hàm xoay vòng:
Sub XoayVong(a)
dong = UBound(a,1)
cot = UBound(a,2)
Dim b()
Redim b(1 To dong) ' dùng để tạm chứa cột 1 của a
For i = 1 To dong
b(i) = a(i,1)
Next i
For j = 1 To cot-1
For i = 1 To dong
a(i, j) = a(i, J+1)
Next i
Next j
For i = 1 To dong
a(i, cot) = b(i)
Next i
End Sub

 

[barney1]

NxN thì khá dễ.
Cứ xoay vòng tròn, ngày 2 thì nhóm phòng 2 lên phòng 1, nhóm phòng 3 lên phòng 2,... nhóm phòng 1 qua phòng 8.

Code chính:
a = [C3:J10].Value
For i = 1 To 7
XoayVong a
[C3:J10].Offset(i, 0).Value = a
Next i

Code hàm xoay vòng:
Sub XoayVong(a)
dong = UBound(a,1)
cot = UBound(a,2)
Dim b()
Redim b(1 To dong) ' dùng để tạm chứa cột 1 của a
For i = 1 To dong
b(i) = a(i,1)
Next i
For j = 1 To cot-1
For i = 1 To dong
a(i, j) = a(i, J+1)
Next i
Next j
For i = 1 To dong
a(i, cot) = b(i)
Next i
End Sub

Cảm ơn bạn, tuy nhiên Code này chỉ chạy được ngày số 1, và chưa thỏa mãn điều kiện : ỨNG VỚI CÁC NGÀY KHÁC NHAU THÌ : TRONG MỘT PHÒNG bất kỳ KHÔNG CÓ >=2 cặp số trùng nhau SO VỚI CÁC NGÀY KHÁC .
Ví dụ ngày 2 ở PHÒNG SỐ 1: có cặp số 58-23 rồi THÌ CÁC NGÀY KHÁC ví dụ Ngày 3 - ở phòng số 1: không được có cặp số 58-23 nữa (xem hình ạ).
Bạn giúp mình nhé!

 

[HUONGHCKT]

Nhờ các anh, các chị giải quyết giúp em bài này với ạ.
Cho danh sách số người từ số 1 đến số 64 nằm trong khoảng L3:L66
cách để sắp xếp ngẫu nhiên , không lặp lại số 1 đến 64 VÀO trong 8 phòng, và sắp cho 7 ngày
(Là tương ứng là ngày 1, 2,3,4,5,6,7- chú ý Ngày số 1 thì mong muốn sắp xếp cố định như file) .
Thỏa mãn điều kiện : ỨNG VỚI CÁC NGÀY KHÁC NHAU THÌ : TRONG MỘT PHÒNG bất kỳ KHÔNG CÓ >=2 cặp số trùng nhau SO VỚI CÁC NGÀY KHÁC .
Ví dụ ngày 2 ở PHÒNG SỐ 1: có cặp số 58-23 rồi THÌ CÁC NGÀY KHÁC ví dụ Ngày 3 - ở phòng số 1: không được có cặp số 58-23 nữa (xem hình ạ).

Nhờ các bác và anh chị viết giúp code này với ạ!!!

View attachment 288695
N

Thử code này xem sao, vẫn là code của chủ thớt có sửa lại đôi chút.

Sub ShuffleNumbers1()
    Dim arrNums() As Integer
    Dim i As Integer, j As Integer, k As Integer
    Dim temp As Integer
    Dim rng As Range
    Dim S, r&
S = Array(, 11, 19, 27, 35, 43, 51)

    ReDim arrNums(1 To 64)
    For i = 1 To 64
        arrNums(i) = i
    Next i
 
For r = 1 To UBound(S)
  Set rng = Range("C" & S(r)).Resize(8, 8)

    For i = 64 To 2 Step -1
        j = Int((i - 1 + 1) * Rnd + 1)
        temp = arrNums(i)
        arrNums(i) = arrNums(j)
        arrNums(j) = temp
    Next i
    Randomize

    For i = 1 To rng.Cells.Count
        k = (i - 1) Mod 64 + 1
        rng.Cells(i).Value = arrNums(k)
    Next i
  Next r
End Sub

 

[barney1]

Thử code này xem sao, vẫn là code của chủ thớt có sửa lại đôi chút.

Sub ShuffleNumbers1()
    Dim arrNums() As Integer
    Dim i As Integer, j As Integer, k As Integer
    Dim temp As Integer
    Dim rng As Range
    Dim S, r&
S = Array(, 11, 19, 27, 35, 43, 51)

    ReDim arrNums(1 To 64)
    For i = 1 To 64
        arrNums(i) = i
    Next i
 
For r = 1 To UBound(S)
  Set rng = Range("C" & S(r)).Resize(8, 8)

    For i = 64 To 2 Step -1
        j = Int((i - 1 + 1) * Rnd + 1)
        temp = arrNums(i)
        arrNums(i) = arrNums(j)
        arrNums(j) = temp
    Next i
    Randomize

    For i = 1 To rng.Cells.Count
        k = (i - 1) Mod 64 + 1
        rng.Cells(i).Value = arrNums(k)
    Next i
  Next r
End Sub

Cảm ơn bác nhiều nhiều ạ!

 

[VetMini]

...
Ví dụ ngày 2 ở PHÒNG SỐ 1: có cặp số 58-23 rồi THÌ CÁC NGÀY KHÁC ví dụ Ngày 3 - ở phòng số 1: không được có cặp số 58-23 nữa...

Lô gic của bạn hiểu chết liền.
Nếu ngày 2 có cặp 58-23 ở phòng số 1 thì sang ngày 3, phép xoay vòng đã đưa cặp này sang phòng sô 8 rồi. Mỗi ngày, mỗi nhóm 8 người sẽ chuyển từ phòng N sang IF(N>1, N-1, 8). Làm sao có chuyện thằng "ở lại phòng cũ".

 

[bebo021999]

Cảm ơn bác nhiều nhiều ạ!

KQ từ bài #4 thế này có hợp lệ không?

 

[HieuCD]

Nhờ các anh, các chị giải quyết giúp em bài này với ạ.
Cho danh sách số người từ số 1 đến số 64 nằm trong khoảng L3:L66
cách để sắp xếp ngẫu nhiên , không lặp lại số 1 đến 64 VÀO trong 8 phòng, và sắp cho 7 ngày
(Là tương ứng là ngày 1, 2,3,4,5,6,7- chú ý Ngày số 1 thì mong muốn sắp xếp cố định như file) .
Thỏa mãn điều kiện : ỨNG VỚI CÁC NGÀY KHÁC NHAU THÌ : TRONG MỘT PHÒNG bất kỳ KHÔNG CÓ >=2 cặp số trùng nhau SO VỚI CÁC NGÀY KHÁC .
Ví dụ ngày 2 ở PHÒNG SỐ 1: có cặp số 58-23 rồi THÌ CÁC NGÀY KHÁC ví dụ Ngày 3 - ở phòng số 1: không được có cặp số 58-23 nữa (xem hình ạ).

Nhờ các bác và anh chị viết giúp code này với ạ!!!

View attachment 288695
N

Với số ngày khá ít
Kiểm tra lại . . .

Sub XYZ()
  Dim arr(), a(), b(), t(), aRnd(), aDup(), res()
  Dim sRow&, sCol&, N&, d&, i&, j&, k&, r&, r2&, c&, q&, tmp$
 
  Const sDate& = 7
  Range("C11:J1000").ClearContents
  arr = Range("C3:J10").Value
  sRow = UBound(arr): sCol = UBound(arr, 2): N = sRow * sCol
 
  ReDim a(1 To N): ReDim b(1 To N)
  ReDim t(1 To sDate - 1, 1 To sCol)
  For j = 1 To sCol
    t(1, j) = ","
    For i = 1 To sRow
      k = k + 1
      a(k) = arr(i, j)
      t(1, j) = t(1, j) & a(k) & ","
    Next i
  Next j
  Randomize
  For d = 2 To sDate
    q = 0
TinhLai:
    ReDim res(1 To sRow, 1 To sCol)
    ReDim aDup(1 To d - 1, 1 To sCol)
    Call UniqueRand(a, b, N)
    k = 0
    For j = 1 To sCol
      If d < sDate Then t(d, j) = ","
      For i = 1 To sRow
        k = k + 1
        tmp = b(k)
        For r = 1 To d - 1
          If InStr(1, t(r, j), "," & tmp & ",") Then
            If aDup(r, j) = 1 Then
              For c = N To k + 1 Step -1
                For r2 = 1 To d - 1
                  If InStr(1, t(r2, j), "," & b(c) & ",") Then Exit For
                Next r2
                If r2 = d Then
                  b(k) = b(c)
                  b(c) = tmp
                  GoTo GhiKetQua
                End If
              Next c
              If c = k Then
                q = q + 1
                If q = 101 Then 'Moi ngay duoc tinh ngau nhien 100 lan
                  Range("C11:J1000").ClearContents
                  MsgBox ("Tieu roi!" & String(2, Chr(10)) & "Hy vong chay Code lan sau ra ket qua!")
                  Exit Sub
                Else
                  GoTo TinhLai
                End If
              End If
            Else
              aDup(r, j) = aDup(r, j) + 1
            End If
          End If
        Next r
GhiKetQua:
        res(i, j) = b(k)
        If d < sDate Then t(d, j) = t(d, j) & b(k) & ","
      Next i
    Next j
    Range("C3").Offset(sRow * (d - 1)).Resize(sRow, sCol) = res
  Next d
End Sub

Private Sub UniqueRand(a, arr, ByVal N As Long)
  Dim i&, RndNum&, tmp&
  ReDim arr(1 To N)
  For i = 1 To N
    RndNum = Int(N * Rnd() + 1)
    If arr(RndNum) = Empty Then tmp = a(RndNum) Else tmp = arr(RndNum)
    If arr(N) = 0 Then arr(RndNum) = a(N) Else arr(RndNum) = arr(N)
    arr(N) = tmp
    N = N - 1
  Next i
End Sub