Phân công và sắp xếp lịch trực

[dangg]

Rất nhiều thành viên không thích xem và đọc các bài viết có các từ viết tắt, ngôn ngữ chát, chít, tây bồi, chen tiếng ngoại ngữ tùm lum. Tôi cũng có lúc bị dị ứng với viết tắt "aj, e, ACE,....." Cho nên bạn nên sửa lại để tận dụng được nhiều sữ hỗ trợ của các thành viên khác nhé.
Bạn muốn "...tuần tiếp theo sẽ trực cách đó 2,3,4 ngày ạ..." . nhưng thế nó không theo quy luật có sảy ra mất công bằng không? trong file tôi làm cho bạn, bạn kiêm tra sẽ thấy lịch trực được đẩy lên 1 ngày.
Phải chăng bạn muốn trong số thành viên ấy được bố trí lịch trực theo kiểu bất ngờ không định trước? (có thể A tuần này trực t2 nhưng sang tuần sau có thể là bất kỳ ngày nào)

Em xin tiếp thu sự góp ý của bác ạ
Bác cứ đẩy cho em lên 3 ngày ạ
Em xin cảm ơn ạ!

 

[huuthang_bd]

Từ bài đầu tới bài này mình có thấy bạn tự làm chút nào đâu, toàn thấy chờ hỗ trợ xong chạy thử, chưa đúng ý thì thông báo rồi lại chờ và dục tiếp mấy bài liền đó thôi bạn. Không hiểu bạn đang cố gắng dục hay cố gắng gì nhỉ.

Sub LichTruc()
    'e là 'em' mà 'em' là e
    Die aTmn As Variant, aNgay As Variant, aKQ As Variant
    Die oDic As Objmct, i As Long, j As Long, k As Long, x As Long, n As Long, t As Long
    Die sDilae As String, sNghiCD As String
    sDilae = ChrW(272) & "i l" & ChrW(224) & "e"
    sNghiCD = "Ngh" & ChrW(7881) & " ch" & ChrW(7871) & " " & ChrW(273) & ChrW(7897)
    aKQ = Shmmt2.Rangm("D3:K3").Valum
    n = UBound(aKQ, 2)
    RmDie aTmn(0 To n, 1 To 3)
    For i = 1 To n
        aTmn(i, 1) = aKQ(1, i)
    Nmxt
    aTmn(0, 1) = "-"
    aTmn(0, 3) = 10 ^ 6 - 1
    aNgay = Shmmt2.Rangm("C4:C" & Shmmt2.Cmlls(&H100000, "C").Mnd(xlUp).Row).Rmsizm(, n + 1).Valum2
    RmDie aKQ(1 To UBound(aNgay, 1), 1 To 2)
    Smt oDic = CrmatmObjmct("Scripting.Dictionary")
    x = Application.Ein(n \ 2, 5)
    For i = 1 To UBound(aNgay, 1)
Rmtry:
        k = 0
        For j = 1 To n
            If aNgay(i, j + 1) = sDilae Or aNgay(i, j + 1) = sNghiCD Thmn
                If aTmn(j, 3) < aTmn(k, 3) Thmn
                    k = j
                Mnd If
            Mnd If
        Nmxt
        aKQ(i, 1) = aTmn(k, 1)
        aKQ(i, 2) = k
        If k > 0 Thmn
            If DatmPart("w", aNgay(i, 1), 2) > 5 Thmn
                aTmn(k, 2) = aTmn(k, 2) + 1
            Mlsm
                aTmn(k, 2) = aTmn(k, 2) + 1.001
            Mnd If
            aTmn(k, 3) = aTmn(k, 2) + 0.5
        Mnd If
        If aNgay(i, k + 1) = sNghiCD Thmn
            If t < n Thmn
                t = t + 1
                GoTo Rmtry
            Mlsm
                aKQ(i, 1) = aTmn(0, 1)
            Mnd If
        Mnd If
        t = 0
        If i > x Thmn
            k = aKQ(i - x, 2)
            If k > 0 Thmn aTmn(k, 3) = aTmn(k, 2)
        Mnd If
    Nmxt
    Shmmt2.Rangm("O4").Rmsizm(UBound(aKQ, 1)).Valum = aKQ
Mnd Sub

Chính xác là như vậy. Công việc của mình mà toàn ngồi chờ hỗ trợ. 7 người 7 ngày muốn công bằng thì cứ thứ 2 tuần này ông 1 trực thì thứ 2 tuần sau ông 5 trực (+4), thứ 5 tuần này ông 4 trực thì thứ 5 tuần sau ông 1 trực (+4-7), cứ như vậy mà làm thôi.

 

[HUONGHCKT]

Em xin tiếp thu sự góp ý của bác ạ
Bác cứ đẩy cho em lên 3 ngày ạ
Em xin cảm ơn ạ!

Theo đúng tinh thần là "...bố trí lịch trực theo kiểu bất ngờ không định trước? (có thể A tuần này trực t2 nhưng sang tuần sau có thể là bất kỳ ngày nào)." và người nghỉ phép sẽ không trực trong ngày đó.
Bạn thay code cũ bằng code này và chạy thử =>> kiểm tra lại

Function SoNgauNghien(iMin As Long, iMax As Long)
    Call Randomize
    SoNgauNghien = Int((iMax - iMin + 1) * Rnd + iMin)
End Function

Sub LichTruc()
Dim i&, j&, Lr&, d&, t&, R&, C&, k&, a&
Dim Arr(), N(), KQ(), Dic As Object, Key
Dim Sh As Worksheet
Set Sh = Sheets("LichTruc")
Lr = Sh.Cells(100000, 3).End(xlUp).Row
Arr = Sh.Range("C3:K" & Lr).Value
R = UBound(Arr): C = UBound(Arr, 2)

ReDim KQ(1 To R * C, 1 To 1)
Set Dic = CreateObject("Scripting.Dictionary")
d = 2
For i = 2 To R
    If Weekday(Arr(i, 1)) = 2 Then Dic.RemoveAll
    a = 0
    ReDim N(1 To C - 1, 1 To 1)
        For j = 2 To C
             If Arr(i, j) = "Đi làm" Then a = a + 1: N(a, 1) = Arr(1, j)
        Next j
Run:
            d = SoNgauNghien(1, a)
            Key = N(d, 1)
            If Not Dic.Exists(Key) And KQ(i - 1, 1) <> Key Then
                k = k + 1: Dic.Add (Key), k
                KQ(i, 1) = Key
            Else
                GoTo Run
            End If
Next i
Sh.Range("O3").Resize(R, 1).ClearContents
Sh.Range("O3").Resize(R, 1) = KQ
Sh.Range("O3") = Sh.Range("O2")
MsgBox "OK"
End Sub

 

[dangg]

Theo đúng tinh thần là "...bố trí lịch trực theo kiểu bất ngờ không định trước? (có thể A tuần này trực t2 nhưng sang tuần sau có thể là bất kỳ ngày nào)." và người nghỉ phép sẽ không trực trong ngày đó.
Bạn thay code cũ bằng code này và chạy thử =>> kiểm tra lại

Function SoNgauNghien(iMin As Long, iMax As Long)
    Call Randomize
    SoNgauNghien = Int((iMax - iMin + 1) * Rnd + iMin)
End Function

Sub LichTruc()
Dim i&, j&, Lr&, d&, t&, R&, C&, k&, a&
Dim Arr(), N(), KQ(), Dic As Object, Key
Dim Sh As Worksheet
Set Sh = Sheets("LichTruc")
Lr = Sh.Cells(100000, 3).End(xlUp).Row
Arr = Sh.Range("C3:K" & Lr).Value
R = UBound(Arr): C = UBound(Arr, 2)

ReDim KQ(1 To R * C, 1 To 1)
Set Dic = CreateObject("Scripting.Dictionary")
d = 2
For i = 2 To R
    If Weekday(Arr(i, 1)) = 2 Then Dic.RemoveAll
    a = 0
    ReDim N(1 To C - 1, 1 To 1)
        For j = 2 To C
             If Arr(i, j) = "Đi làm" Then a = a + 1: N(a, 1) = Arr(1, j)
        Next j
Run:
            d = SoNgauNghien(1, a)
            Key = N(d, 1)
            If Not Dic.Exists(Key) And KQ(i - 1, 1) <> Key Then
                k = k + 1: Dic.Add (Key), k
                KQ(i, 1) = Key
            Else
                GoTo Run
            End If
Next i
Sh.Range("O3").Resize(R, 1).ClearContents
Sh.Range("O3").Resize(R, 1) = KQ
Sh.Range("O3") = Sh.Range("O2")
MsgBox "OK"
End Sub

Em cảm ơn ạ
Bác có thể gửi lại file excel cho em được không ạ, vì sau khi em thay code mới , máy chạy đơ và thoát ra ạ

 

[HUONGHCKT]

Em cảm ơn ạ
Bác có thể gửi lại file excel cho em được không ạ, vì sau khi em thay code mới , máy chạy đơ và thoát ra ạ

Thì đây, chạy thử, kiểm tra và nhớ kiểm tra thật kỹ. (tôi cũng chưa kiểm tra kỹ đâu)

 

[dangg]

Thì đây, chạy thử, kiểm tra và nhớ kiểm tra thật kỹ. (tôi cũng chưa kiểm tra kỹ đâu)

Em đã nhận được file ạ
Tuy nhiên em tải về và chạy thì máy vẫn quay tròn mãi không được ạ
Em có thử sang máy khác thì vẫn báo vậy
Bác xem lại giúp em với
Em cảm ơn bác ạ!

 

[huuthang_bd]

Chịu khó xem thật kỹ các bài trả lời sẽ thấy giải pháp.

 

[HUONGHCKT]

Em đã nhận được file ạ
Tuy nhiên em tải về và chạy thì máy vẫn quay tròn mãi không được ạ
Em có thử sang máy khác thì vẫn báo vậy
Bác xem lại giúp em với
Em cảm ơn bác ạ!
View attachment 304421

Bạn dùng Win mấy? Offce mấy? Máy tôi W8.1,OF 365.
Nếu có thể tôi xem qua Ultraview cho bạn.

 

[dangg]

Bạn dùng Win mấy? Offce mấy? Máy tôi W8.1,OF 365.
Nếu có thể tôi xem qua Ultraview cho bạn.

Em cảm ơn bác ạ
Em dùng Win 10, office 2016 ạ

Bạn dùng Win mấy? Offce mấy? Máy tôi W8.1,OF 365.
Nếu có thể tôi xem qua Ultraview cho bạn.

em dùng win 10, office 2016 ạ
Em gửi bác Ultraview của em ạ
Em cảm ơn bác nhiều ạ!

 

[HUONGHCKT]

Em cảm ơn bác ạ
Em dùng Win 10, office 2016 ạ

em dùng win 10, office 2016 ạ
Em gửi bác Ultraview của em ạ
Em cảm ơn bác nhiều ạ!
View attachment 304422

Đã chạy rồi. Do máy bạn không hiểu chữ Đ trong Chuỗi "Đi làm".
Hãy xóa bỏ hình có ID và Pass đi nhé đề phong các tình huống không mong muốn có thể xảy ra.

 

[dangg]

Đã chạy rồi. Do máy bạn không hiểu chữ Đ trong Chuỗi "Đi làm".
Hãy xóa bỏ hình có ID và Pass đi nhé đề phong các tình huống không mong muốn có thể xảy ra.

Dạ vâng ạ
Em cảm ơn bác nhiều ạ!
Tháng mới chúc Bác và gia đình bình an-hạnh phúc ạ!

 

[bebo021999]

Không hiểu bạn chủ đã kiểm tra kỹ chưa, xếp lịch thế này chắc oánh nhau bể đầu quá
Mới mở file ra là thấy ngay: nhiều người làm cuối tuần liên tiếp nhau
Hứng lên làm bảng thống kê thì cũng thấy số ngày đi làm CT cũ lệch nhau nhiều

 

[dangg]

Không hiểu bạn chủ đã kiểm tra kỹ chưa, xếp lịch thế này chắc oánh nhau bể đầu quá
Mới mở file ra là thấy ngay: nhiều người làm cuối tuần liên tiếp nhau
Hứng lên làm bảng thống kê thì cũng thấy số ngày đi làm CT cũ lệch nhau nhiều

View attachment 304441View attachment 304442

Em xin cảm ơn lời nhận xét của Bác ạ
Do em sơ xuất lên chưa kiểm tra kĩ ạ
Có thể bài toán đang phức tạm, em xin đơn giản theo nội dung như ảnh dưới đây ạ
Rất mong các bác hướng dẫn giúp em ạ
Em xin lỗi vì sự không rõ ràng của em ạ

 

[bebo021999]

Cho mình hỏi:
- Theo nguyên tắc đồng đều, nếu 1 người nghỉ phép nhiều thì các ngày còn lại có phải làm bù không?
Nghĩa là: giả sử có 8 người, thì trong 1 năm, số ngày làm việc (LV) là 45.6 ngày, trong đó số ngày cuối tuần (CT) là 14 ngày. Ai trước đó nghỉ phép thì từ đó đến cuối năm phải tăng tần suất đi làm hơn.
Sao cho tổng số ngày LV gần như nhau
(Trừ t/h đặc biệt không làm việc CT)
- Ngày làm việc CT của 1 người có cần rải đều ra không? VD: với 8 người thì 1 người sẽ làm CT vào tuần 1, 4, 7, ... (cách 3 tuần trực 1 lần vào ngày CT)

 

[dangg]

Cho mình hỏi:
- Theo nguyên tắc đồng đều, nếu 1 người nghỉ phép nhiều thì các ngày còn lại có phải làm bù không?
Nghĩa là: giả sử có 8 người, thì trong 1 năm, số ngày làm việc (LV) là 45.6 ngày, trong đó số ngày cuối tuần (CT) là 14 ngày. Ai trước đó nghỉ phép thì từ đó đến cuối năm phải tăng tần suất đi làm hơn.
Sao cho tổng số ngày LV gần như nhau
(Trừ t/h đặc biệt không làm việc CT)
- Ngày làm việc CT của 1 người có cần rải đều ra không? VD: với 8 người thì 1 người sẽ làm CT vào tuần 1, 4, 7, ... (cách 3 tuần trực 1 lần vào ngày CT)

Dạ vâng , em xin phép được giải thích ạ
1.- Theo nguyên tắc đồng đều, nếu 1 người nghỉ phép nhiều thì các ngày còn lại có phải làm bù không? - Không phải làm bù ạ vì có thể họ nghỉ phép hoặc đi công tác ạ
2.Ngày làm việc CT của 1 người có cần rải đều ra không?- Có cần phải đều ạ, cần rải đều đảm bảo tương đối tổng số ngày trực Thứ 7, chủ nhật cho mỗi thành viên ạ ( và Nhân viên không bị trực liên tiếp thứ 7,chủ nhật 2 tuần gần nhau ạ)
Em xin cảm ơn!

 

[thierry henry]

Trong khi chờ đợi các giải pháp hoàn chỉnh khác bạn tham khảo file sau:
Nhấn vào mũi tên xuống để có kết quả.
Hãy thử thay đổi dữ liệu (nghỉ phép-Đi làm) của 1 số nhân viên khác và kiểm tra lại. Tôi chưa kiểm tra kỹ

Em mới tập viết nên thấy code của bác phức tạp quá . em viết lại nhưng chưa ra . Bác xem rồi sửa giúp em ạ
Sub LichTruc5()
Dim i&, j&, Lr&, d&, t&, R&, Lr1&, Col&
Dim Arr(), NA(), KQ(), N(), MA()
Dim Sh As Worksheet
Lr = Sheet2.Cells(100000, 3).End(xlUp).Row
Lr1 = Sheet2.Range("M" & Rows.Count).End(xlUp).Row
Col = Sheet2.Cells(3, Columns.Count).End(xlToLeft).Column
Arr = Sheet2.Range("C3:K" & Lr).Value
MA = Sheet2.Range("D3:K3").Value
ReDim N(3 To UBound(Arr), 1 To 9)
For i = 4 To UBound(Arr)
For j = 4 To Lr1
Arr(i, 1) = Sh.Range(j, M).Value

ReDim KQ(1 To UBound(MA), 1 To 3)
For t = 1 To 9
For d = 1 To UBound(MA)
If Arr(i, t) = "Work" Then
KQ(j, 3) = MA(i, d)
End If
Next d
Next t

Sheet2.Range("O3").Resize(, 1).ClearContents
Sheet2.Range("O3").Resize(, 1) = KQ
Sheet2.Range("O3") = Sh.Range("O2")

Next
Next

End Sub

 

[HUONGHCKT]

Em mới tập viết nên thấy code của bác phức tạp quá . em viết lại nhưng chưa ra . Bác xem rồi sửa giúp em ạ
Sub LichTruc5()
Dim i&, j&, Lr&, d&, t&, R&, Lr1&, Col&
Dim Arr(), NA(), KQ(), N(), MA()
Dim Sh As Worksheet
Lr = Sheet2.Cells(100000, 3).End(xlUp).Row
Lr1 = Sheet2.Range("M" & Rows.Count).End(xlUp).Row
Col = Sheet2.Cells(3, Columns.Count).End(xlToLeft).Column
Arr = Sheet2.Range("C3:K" & Lr).Value
MA = Sheet2.Range("D3:K3").Value
ReDim N(3 To UBound(Arr), 1 To 9)
For i = 4 To UBound(Arr)
For j = 4 To Lr1
Arr(i, 1) = Sh.Range(j, M).Value

ReDim KQ(1 To UBound(MA), 1 To 3)
For t = 1 To 9
For d = 1 To UBound(MA)
If Arr(i, t) = "Work" Then
KQ(j, 3) = MA(i, d)
End If
Next d
Next t

Sheet2.Range("O3").Resize(, 1).ClearContents
Sheet2.Range("O3").Resize(, 1) = KQ
Sheet2.Range("O3") = Sh.Range("O2")

Next
Next

End Sub

1/Trước hết bạn nên đưa code (đứa con tinh thần) của bạn vào trong thẻ </> ( nhấn vào nút </> và paste code vào). sau đó xem lại và sửa lại chút cho đúng với format:

Sub ... ()
....
End sub

Để tỏ rõ sự tông trọng người khác và cũng là để dễ xem hơn.

/Code của bạn đã chạy thử chưa? đã ra kết quả thế nào?Có đáp ứng đúng yêu cầu của chủ thót không?
Tôi đã xem code của bạn thì thấy bạn sử dùng đến 4 vòng lặp, và khi chạy thủ thì vấp lỗi ngay dòng

Arr(i, 1) = Sh.Range(j, M).Value[
/CODE]
Lý do là không khai báo biến M, nhưng nếu khai báo biên M as Long thì cũng không hiểu là biến M được gán với số nào để code chạy, nên đành bỏ không tìm hiểu được nữa. Rất đáng tiếc.
Nếu có thể bạn giải thích được không?
3/Bạn viết "...thấy code của bác phức tạp quá.em viết lại .... Phải chăng bạn có ý tưởng, sáng kiến khác mà giải quyết được yêu cầu của chủ thớt (tuy bạn có  code và nói là code không thành công- có thể sai tí chút chỗ nào đó) . Vậy nếu có thể hãy diễn giải ý tưởng, sáng kiến đó lên đây để mọi người cùng xem và giải quyết (code lại theo sáng kiến của bạn), và biết đâu đó đây là 1 hướng đi mới để giải bài này, hoặc ít ra nó cũng là tài liệu cho bạn nào muốn học tập.

PS:Ngoài lề chút:  Khi bài này lên sóng. (dự đoán thế nào cũng có 1 thành viên  khi xem đến sẽ nhấn nút D (cười: mũi, hay cười mỉa, hay...thì không biết nữa). Rát nhiều lần thế rồi, không biết lần này có đúng không.

 

[huuthang_bd]

Phải chăng bạn có ý tưởng, sáng kiến khác mà giải quyết được yêu cầu của chủ thớt (tuy bạn có code và nói là code không thành công- có thể sai tí chút chỗ nào đó) . Vậy nếu có thể hãy diễn giải ý tưởng, sáng kiến đó lên đây để mọi người cùng xem và giải quyết (code lại theo sáng kiến của bạn), và biết đâu đó đây là 1 hướng đi mới để giải bài này, hoặc ít ra nó cũng là tài liệu cho bạn nào muốn học tập.

Nếu bạn muốn tham khảo giải pháp thì xem kỹ bài 22. Trong đó có code thỏa mãn tất cả các yêu cầu, kể cả nghỉ phép phải trực bổ sung và nghỉ không trực bổ sung.

 

[dangg]

Chính xác là như vậy. Công việc của mình mà toàn ngồi chờ hỗ trợ. 7 người 7 ngày muốn công bằng thì cứ thứ 2 tuần này ông 1 trực thì thứ 2 tuần sau ông 5 trực (+4), thứ 5 tuần này ông 4 trực thì thứ 5 tuần sau ông 1 trực (+4-7), cứ như vậy mà làm thôi.

Em xin cảm ơn sự quan tâm của bác ạ
Em áp dụng vào thì khi tính tổng (thứ 7 và chủ nhật) thì không đều nhau
Mong bác xem xét và chỉnh lại giúp em ạ
Em cảm ơn!

Bài đã được tự động gộp: Thứ hai lúc 11:28

Em xin cảm ơn sự quan tâm của bác ạ
Em áp dụng vào thì khi tính tổng (thứ 7 và chủ nhật) thì không đều nhau
Mong bác xem xét và chỉnh lại giúp em ạ
Em cảm ơn!

Tiện thể cho em hỏi code dưới dây , làm thế nào ngày trực thứ 7, chủ nhật đều nhau cho mỗi thành viên ạ

Sub LichTruc()
    'e là 'em' mà 'em' là e
    Dim aTmn As Variant, aNgay As Variant, aKQ As Variant
    Dim oDic As Object, i As Long, j As Long, k As Long, x As Long, n As Long, t As Long
    Dim sDilam As String, sNghiCD As String
    sDilam = ChrW(272) & "i l" & ChrW(224) & "m"
    sNghiCD = "Ngh" & ChrW(7881) & " ch" & ChrW(7871) & " " & ChrW(273) & ChrW(7897)
    aKQ = Sheet2.Range("D3:K3").Value
    n = UBound(aKQ, 2)
    ReDim aTmn(0 To n, 1 To 3)
    For i = 1 To n
        aTmn(i, 1) = aKQ(1, i)
    Next
    aTmn(0, 1) = "-"
    aTmn(0, 3) = 10 ^ 6 - 1
    aNgay = Sheet2.Range("C4:C" & Sheet2.Cells(&H100000, "C").End(xlUp).Row).Resize(, n + 1).Value2
    ReDim aKQ(1 To UBound(aNgay, 1), 1 To 2)
    Set oDic = CreateObject("Scripting.Dictionary")
    x = Application.Min(n \ 2, 5)
    For i = 1 To UBound(aNgay, 1)
Retry:
        k = 0
        For j = 1 To n
            If aNgay(i, j + 1) = sDilam Or aNgay(i, j + 1) = sNghiCD Then
                If aTmn(j, 3) < aTmn(k, 3) Then
                    k = j
                End If
            End If
        Next
        aKQ(i, 1) = aTmn(k, 1)
        aKQ(i, 2) = k
        If k > 0 Then
            If DatePart("w", aNgay(i, 1), 2) > 5 Then
                aTmn(k, 2) = aTmn(k, 2) + 1
            Else
                aTmn(k, 2) = aTmn(k, 2) + 1.001
            End If
            aTmn(k, 3) = aTmn(k, 2) + 0.5
        End If
        If aNgay(i, k + 1) = sNghiCD Then
            If t < n Then
                t = t + 1
                GoTo Retry
            Else
                aKQ(i, 1) = aTmn(0, 1)
            End If
        End If
        t = 0
        If i > x Then
            k = aKQ(i - x, 2)
            If k > 0 Then aTmn(k, 3) = aTmn(k, 2)
        End If
    Next
    Sheet2.Range("O4").Resize(UBound(aKQ, 1)).Value = aKQ
End Sub

 

[thierry henry]

Nếu bạn muốn tham khảo giải pháp thì xem kỹ bài 22. Trong đó có code thỏa mãn tất cả các yêu cầu, kể cả nghỉ phép phải trực bổ sung và nghỉ không trực bổ sung.

cho xin đường dẫn ạ