Sắp xếp ngẫu nhiên có điều kiện

[hungdiep85]

Chào các Anh Chị
nhờ anh chị giúp em đoạn code

sắp xếp ngẫu nhiên theo B3 đến D162, mỗi tổ sẽ sản xuất "Mẫu, Màu, Đế".

Điều kiện: trong thời gian 2 tiếng màu và đế sẽ không trùng với tổ khác và "Màu, Đế" đã sản xuất sẽ không sản xuất lại trong một ngày :

ví dụ "Màu xanh, Đế đỏ" và "Màu đỏ, Đế xanh" sẽ không sản xuất trong một ngày. (chỉ sản xuất một trong hai)

và thời gian 01:00PM đến 03:00PM sẽ không sản xuất màu hoạt đế có màu trắng và màu đen.

Em cảm ơn trước ạ

 

[HieuCD]

Dạ. Anh ơi
em gặp trường hợp tổ 1 và tổ 2 đang làm 01:00PM đến 03:00PM, 02:00PM tổ 7 và tổ 8 vào ca, thì bị lấy màu của tổ 1 và tổ 2 đang làm đến 03:00PM mới xong, Anh xem giúp em với.

Em cảm ơn anh

Code chạy theo thời gian, cùng thời gian không trùng màu
Dữ liệu file thiếu màu

Option Compare Text
Dim sArr(), aGio(), Res(), Dic As Object, Dic2 As Object
Dim i&, d&

Sub NgauNhienNhieuDieuKien()
  Dim Loai$, iKey, fGio, fRow&
  Dim sRow&, eRow&, n&, sMau&, skMau&
 
  Set Dic = CreateObject("scripting.dictionary")
  Set Dic2 = CreateObject("scripting.dictionary")
  eRow = Range("B" & Rows.Count).End(xlUp).Row
  For i = 3 To eRow
    mau = Range("C" & i).Value: de = Range("C" & i).Value
    Dic.Item(Range("C" & i).Value) = ""
    Dic.Item(Range("D" & i).Value) = ""
    If Loai <> Range("B" & i).Value Then
      fRow = i
      Loai = Range("B" & i).Value
    End If
    If Loai <> Range("B" & i + 1).Value Then
      n = n + 1
      ReDim Preserve sArr(1 To n)
      sArr(n) = Range("B" & fRow & ":D" & i).Value
      Dic2.Item(Loai) = n
    End If
  Next i
  sMau = Dic.Count: Dic.RemoveAll
  aGio = Range("E3", Range("I" & Rows.Count).End(xlUp)).Value
  sRow = UBound(aGio)
  ReDim Res(1 To sRow, 1 To 2)
  Randomize
 
  For i = 1 To sRow
    If fGio <> aGio(i, 2) Then
      fRow = i
      fGio = aGio(i, 2)
      For Each iKey In Dic.keys
        If Dic.Item(iKey) <= fGio + 0.0005 Then Dic.Remove (iKey)
      Next iKey
    End If
    If aGio(i, 1) <> Empty Then skMau = 4 Else skMau = 2
    If Dic.Count > sMau - skMau Then
      MsgBox ("So luong màu khong du phan bo!"): Exit Sub
    End If
    d = 0
    Call CreateRes(Dic2.Item(aGio(i, 5)), aGio(i, 1))
    If d = 500 Then
      For r = fRow To i - 1
        Dic.Remove (Res(r, 1))
        Dic.Remove (Res(r, 2))
        Dic2.Remove (Res(r, 1) & Res(r, 2))
        Dic2.Remove (Res(r, 2) & Res(r, 1))
      Next r
      i = fRow - 1
    End If
  Next i

  Range("j3").Resize(sRow, 2) = Res
  Dic2.RemoveAll:  Dic.RemoveAll
End Sub

Private Sub CreateRes(ByVal n&, ByVal unMau$)
  Dim iR&, mau$, de$
 
  sRow = UBound(sArr(n))
  Do While i > 0
    iR = Int(sRow * Rnd + 1)
    mau = sArr(n)(iR, 2):     de = sArr(n)(iR, 3)
    If Dic2.exists(mau & de) = False And Dic2.exists(de & mau) = False Then
      If InStr(1, unMau, mau) = 0 And InStr(1, unMau, de) = 0 Then
        If Dic.exists(de) = False Then
          If Dic.exists(mau) = False Then
            Res(i, 1) = mau: Res(i, 2) = de
            Dic.Add mau, aGio(i, 3): Dic.Add de, aGio(i, 3)
            Dic2.Add mau & de, ""
            Dic2.Add de & mau, ""
            Exit Do
          End If
        End If
      End If
    End If
    d = d + 1
    If d = 500 Then Exit Do
  Loop
End Sub

 

[hungdiep85]

Code chạy theo thời gian, cùng thời gian không trùng màu
Dữ liệu file thiếu màu

Option Compare Text
Dim sArr(), aGio(), Res(), Dic As Object, Dic2 As Object
Dim i&, d&

Sub NgauNhienNhieuDieuKien()
  Dim Loai$, iKey, fGio, fRow&
  Dim sRow&, eRow&, n&, sMau&, skMau&

  Set Dic = CreateObject("scripting.dictionary")
  Set Dic2 = CreateObject("scripting.dictionary")
  eRow = Range("B" & Rows.Count).End(xlUp).Row
  For i = 3 To eRow
    mau = Range("C" & i).Value: de = Range("C" & i).Value
    Dic.Item(Range("C" & i).Value) = ""
    Dic.Item(Range("D" & i).Value) = ""
    If Loai <> Range("B" & i).Value Then
      fRow = i
      Loai = Range("B" & i).Value
    End If
    If Loai <> Range("B" & i + 1).Value Then
      n = n + 1
      ReDim Preserve sArr(1 To n)
      sArr(n) = Range("B" & fRow & ":D" & i).Value
      Dic2.Item(Loai) = n
    End If
  Next i
  sMau = Dic.Count: Dic.RemoveAll
  aGio = Range("E3", Range("I" & Rows.Count).End(xlUp)).Value
  sRow = UBound(aGio)
  ReDim Res(1 To sRow, 1 To 2)
  Randomize

  For i = 1 To sRow
    If fGio <> aGio(i, 2) Then
      fRow = i
      fGio = aGio(i, 2)
      For Each iKey In Dic.keys
        If Dic.Item(iKey) <= fGio + 0.0005 Then Dic.Remove (iKey)
      Next iKey
    End If
    If aGio(i, 1) <> Empty Then skMau = 4 Else skMau = 2
    If Dic.Count > sMau - skMau Then
      MsgBox ("So luong màu khong du phan bo!"): Exit Sub
    End If
    d = 0
    Call CreateRes(Dic2.Item(aGio(i, 5)), aGio(i, 1))
    If d = 500 Then
      For r = fRow To i - 1
        Dic.Remove (Res(r, 1))
        Dic.Remove (Res(r, 2))
        Dic2.Remove (Res(r, 1) & Res(r, 2))
        Dic2.Remove (Res(r, 2) & Res(r, 1))
      Next r
      i = fRow - 1
    End If
  Next i

  Range("j3").Resize(sRow, 2) = Res
  Dic2.RemoveAll:  Dic.RemoveAll
End Sub

Private Sub CreateRes(ByVal n&, ByVal unMau$)
  Dim iR&, mau$, de$

  sRow = UBound(sArr(n))
  Do While i > 0
    iR = Int(sRow * Rnd + 1)
    mau = sArr(n)(iR, 2):     de = sArr(n)(iR, 3)
    If Dic2.exists(mau & de) = False And Dic2.exists(de & mau) = False Then
      If InStr(1, unMau, mau) = 0 And InStr(1, unMau, de) = 0 Then
        If Dic.exists(de) = False Then
          If Dic.exists(mau) = False Then
            Res(i, 1) = mau: Res(i, 2) = de
            Dic.Add mau, aGio(i, 3): Dic.Add de, aGio(i, 3)
            Dic2.Add mau & de, ""
            Dic2.Add de & mau, ""
            Exit Do
          End If
        End If
      End If
    End If
    d = d + 1
    If d = 500 Then Exit Do
  Loop
End Sub

em cảm ơn Anh rất rất nhiều, Anh đã giúp cho công việc dùng 3 giờ để hoàng thành còn lại 1 phút, code mới là hoàng hảo rồi Anh, hy vọng có nhiệp cafe cùng anh.

một lần nữa cảm ơn Anh rất nhiều

 

[hungdiep85]

dạ, do nhu cầu sản xuất có thay đổi,

lúc trước:
ví dụ "Màu xanh, Đế đỏ" và "Màu đỏ, Đế xanh" sẽ không sản xuất trong một ngày. (chỉ sản xuất một trong hai)

bây giờ
ví dụ "Màu xanh, Đế đỏ" đã sản xuất sau 2 giờ thì "Màu đỏ, Đế xanh" vẫn có thể sản xuất.

Anh Chị chỉnh giúp em code trong file giúp à,
Em cảm ơn rất nhiều

 

[hungdiep85]

anh chị giúp em bài này với. Em mò mãi không được. Em xin cảm ơn nhiều.