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

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài
Có
dangg đã viết:
Em áp dụng vào thì khi tính tổng (thứ 7 và chủ nhật) thì không đều nhau
Nhấp chuột vào đây để mở rộng...
Tôi ghi rõ là áp dụng cho trường hợp 7 người 7 ngày, bạn áp dụng cho trường hợp 8 người thì sao đúng được.
Chia đều thứ 7 và chủ nhật sửa code lại như sau:
Mã: 
Sub LichTruc()
    Dim aTen 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, wd 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 aTen(0 To n, 1 To 3)
    For i = 1 To n
        aTen(i, 1) = aKQ(1, i)
    Next
    aTen(0, 1) = "-"
    aTen(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, 3)
    For i = 1 To UBound(aNgay, 1)
        wd = DatePart("w", aNgay(i, 1), 2)
Retry:
        k = 0
        For j = 1 To n
            If aNgay(i, j + 1) = sDilam Or aNgay(i, j + 1) = sNghiCD Then
                If aTen(k, 3) - aTen(j, 3) > 0.1 Then
                    k = j
                ElseIf aTen(k, 3) - aTen(j, 3) > -0.1 Then
                    If wd > 5 Then
                        If Round(aTen(j, 3) - aTen(k, 3), 6) = 0 Then
                            If i - wd - 1 > 0 Then
                                If aKQ(i - wd - 1, 1) = aTen(k, 1) Then
                                    k = j
                                End If
                            End If
                            If i - wd > 0 Then
                                If aKQ(i - wd, 1) = aTen(k, 1) Then
                                    k = j
                                End If
                            End If
                        ElseIf aTen(j, 3) > aTen(k, 3) Then
                            k = j
                        End If
                    Else
                        If aTen(j, 3) < aTen(k, 3) Then k = j
                    End If
                End If
            End If
        Next
        aKQ(i, 1) = aTen(k, 1)
        aKQ(i, 2) = k
        If k > 0 Then
            If wd > 5 Then
                aTen(k, 2) = aTen(k, 2) + 1
            Else
                aTen(k, 2) = aTen(k, 2) + 1.0001
            End If
            aTen(k, 3) = aTen(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) = aTen(0, 1)
            End If
        End If
        t = 0
        If i > x Then
            k = aKQ(i - x, 2)
            If k > 0 Then aTen(k, 3) = aTen(k, 2)
        End If
    Next
    Sheet2.Range("O4").Resize(UBound(aKQ, 1)).Value = aKQ
End Sub
 
huuthang_bd đã viết:
Tôi ghi rõ là áp dụng cho trường hợp 7 người 7 ngày, bạn áp dụng cho trường hợp 8 người thì sao đúng được.
Chia đều thứ 7 và chủ nhật sửa code lại như sau:
Mã: 
Sub LichTruc()
    Dim aTen 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, wd 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 aTen(0 To n, 1 To 3)
    For i = 1 To n
        aTen(i, 1) = aKQ(1, i)
    Next
    aTen(0, 1) = "-"
    aTen(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, 3)
    For i = 1 To UBound(aNgay, 1)
        wd = DatePart("w", aNgay(i, 1), 2)
Retry:
        k = 0
        For j = 1 To n
            If aNgay(i, j + 1) = sDilam Or aNgay(i, j + 1) = sNghiCD Then
                If aTen(k, 3) - aTen(j, 3) > 0.1 Then
                    k = j
                ElseIf aTen(k, 3) - aTen(j, 3) > -0.1 Then
                    If wd > 5 Then
                        If Round(aTen(j, 3) - aTen(k, 3), 6) = 0 Then
                            If i - wd - 1 > 0 Then
                                If aKQ(i - wd - 1, 1) = aTen(k, 1) Then
                                    k = j
                                End If
                            End If
                            If i - wd > 0 Then
                                If aKQ(i - wd, 1) = aTen(k, 1) Then
                                    k = j
                                End If
                            End If
                        ElseIf aTen(j, 3) > aTen(k, 3) Then
                            k = j
                        End If
                    Else
                        If aTen(j, 3) < aTen(k, 3) Then k = j
                    End If
                End If
            End If
        Next
        aKQ(i, 1) = aTen(k, 1)
        aKQ(i, 2) = k
        If k > 0 Then
            If wd > 5 Then
                aTen(k, 2) = aTen(k, 2) + 1
            Else
                aTen(k, 2) = aTen(k, 2) + 1.0001
            End If
            aTen(k, 3) = aTen(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) = aTen(0, 1)
            End If
        End If
        t = 0
        If i > x Then
            k = aKQ(i - x, 2)
            If k > 0 Then aTen(k, 3) = aTen(k, 2)
        End If
    Next
    Sheet2.Range("O4").Resize(UBound(aKQ, 1)).Value = aKQ
End Sub
Nhấp chuột vào đây để mở rộng...
Em xin chân thành cảm ơn bác nhiều ạ!
Bác xem lại giúp em, trong 1 tuần có người phải trực tận 2 hôm?
Mong muốn trải dàn đều ạ
1728289285490.png
 
Lần chỉnh sửa cuối:
dangg đã viết:
Bác xem lại giúp em, trong 1 tuần có người phải trực tận 2 hôm?
Mong muốn trải dàn đều ạ
Nhấp chuột vào đây để mở rộng...
Như thế vẫn chưa đều? Bạn nên xem lại yêu cầu có khả thi hay không, không phải muốn thế nào cũng được.
--
Giờ tôi có 8 người, chỉ cần phân công lịch trực cho 9 ngày từ 19/10/2024 đến 27/10/2024. Điều kiện cũng giống bạn yêu cầu là 1 người không trực 2 cuối tuần liên tục và không trực 2 ngày trong vòng 7 ngày liên tục.
Nếu bạn sắp xếp được thì tôi sẽ viết code cho bạn.
 
Có vẻ như bạn đã có phương án tối ưu rồi.
Vì chỉ có 8 người nên 2 ngày CT trước đó và 5 ngày thường tuần này đã mất 7 người rồi (không lặp), vì vậy CT này chỉ còn 1 người cuối cùng + 1 người lặp lại (Trang)
 
huuthang_bd đã viết:
Như thế vẫn chưa đều? Bạn nên xem lại yêu cầu có khả thi hay không, không phải muốn thế nào cũng được.
--
Giờ tôi có 8 người, chỉ cần phân công lịch trực cho 9 ngày từ 19/10/2024 đến 27/10/2024. Điều kiện cũng giống bạn yêu cầu là 1 người không trực 2 cuối tuần liên tục và không trực 2 ngày trong vòng 7 ngày liên tục.
Nếu bạn sắp xếp được thì tôi sẽ viết code cho bạn.
Nhấp chuột vào đây để mở rộng...
Em xin lỗi, chắc là do em triển khai không hết ý của bài ạ
Nhân viên 1,2 trực thứ 7,chủ nhật tuần trước thì tuần này sẽ trực ngày thứ ( ví dụ thứ 4, thứ5 , giãn ra 2~4 ngày để không bị trực liên tiếp tránh mệt ạ)
Rất mong bác giúp đỡ em ạ
Em cảm ơn!
1728352334758.png
 

dangg đã viết:
Em xin lỗi, chắc là do em triển khai không hết ý của bài ạ
Nhân viên 1,2 trực thứ 7,chủ nhật tuần trước thì tuần này sẽ trực ngày thứ ( ví dụ thứ 4, thứ5 , giãn ra 2~4 ngày để không bị trực liên tiếp tránh mệt ạ)
Rất mong bác giúp đỡ em ạ
Em cảm ơn!
View attachment 304536
Nhấp chuột vào đây để mở rộng...
Bạn muốn phân công công bằng nhưng "ý em là" thì lại là người trực hai ngày người không ngày nào (đến 24/10).
Tôi sẽ dừng ở đây, không tham gia code ở chủ đề này nữa.
 
huuthang_bd đã viết:
Tôi ghi rõ là áp dụng cho trường hợp 7 người 7 ngày, bạn áp dụng cho trường hợp 8 người thì sao đúng được.
Chia đều thứ 7 và chủ nhật sửa code lại như sau:
Mã: 
Sub LichTruc()
    Dim aTen 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, wd 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 aTen(0 To n, 1 To 3)
    For i = 1 To n
        aTen(i, 1) = aKQ(1, i)
    Next
    aTen(0, 1) = "-"
    aTen(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, 3)
    For i = 1 To UBound(aNgay, 1)
        wd = DatePart("w", aNgay(i, 1), 2)
Retry:
        k = 0
        For j = 1 To n
            If aNgay(i, j + 1) = sDilam Or aNgay(i, j + 1) = sNghiCD Then
                If aTen(k, 3) - aTen(j, 3) > 0.1 Then
                    k = j
                ElseIf aTen(k, 3) - aTen(j, 3) > -0.1 Then
                    If wd > 5 Then
                        If Round(aTen(j, 3) - aTen(k, 3), 6) = 0 Then
                            If i - wd - 1 > 0 Then
                                If aKQ(i - wd - 1, 1) = aTen(k, 1) Then
                                    k = j
                                End If
                            End If
                            If i - wd > 0 Then
                                If aKQ(i - wd, 1) = aTen(k, 1) Then
                                    k = j
                                End If
                            End If
                        ElseIf aTen(j, 3) > aTen(k, 3) Then
                            k = j
                        End If
                    Else
                        If aTen(j, 3) < aTen(k, 3) Then k = j
                    End If
                End If
            End If
        Next
        aKQ(i, 1) = aTen(k, 1)
        aKQ(i, 2) = k
        If k > 0 Then
            If wd > 5 Then
                aTen(k, 2) = aTen(k, 2) + 1
            Else
                aTen(k, 2) = aTen(k, 2) + 1.0001
            End If
            aTen(k, 3) = aTen(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) = aTen(0, 1)
            End If
        End If
        t = 0
        If i > x Then
            k = aKQ(i - x, 2)
            If k > 0 Then aTen(k, 3) = aTen(k, 2)
        End If
    Next
    Sheet2.Range("O4").Resize(UBound(aKQ, 1)).Value = aKQ
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ em đa thử nhưng code của anh chị không cho ra kết quả . Và em lại mò mẫm viết tiếp cái mới sau khi hiểu ý đồ của anh chị nhưng dễ hiểu hơn , có thuyết minh . nó chạy được , không bị bắt lỗi nhưng không ra kết quả . anh chị cao minh sửa lại giúp em . em cảm ơn
 
thierry henry đã viết:
Dạ em đa thử nhưng code của anh chị không cho ra kết quả . Và em lại mò mẫm viết tiếp cái mới sau khi hiểu ý đồ của anh chị nhưng dễ hiểu hơn , có thuyết minh . nó chạy được , không bị bắt lỗi nhưng không ra kết quả . anh chị cao minh sửa lại giúp em . em cảm ơn
Nhấp chuột vào đây để mở rộng...
Bạn trích dẫn bài #42 nên tôi hiểu là bạn nói code ở bài #42 không cho ra kết quả.
Bạn hãy gửi file mà bạn sử dụng code ở bài #42 nhưng không ra kết quả lên, tôi sẽ giúp bạn kiểm tra nguyên nhân.
 
huuthang_bd đã viết:
Bạn trích dẫn bài #42 nên tôi hiểu là bạn nói code ở bài #42 không cho ra kết quả.
Bạn hãy gửi file mà bạn sử dụng code ở bài #42 nhưng không ra kết quả lên, tôi sẽ giúp bạn kiểm tra nguyên nhân.
Nhấp chuột vào đây để mở rộng...
dạ không là cái này ạ

Sub Lichtruc8()
Dim cend As Long, arr As Variant, i As Long, j As Long, data As Variant, kq As Variant
Dim rend As Long, d As Long, k
With Sheets("LichTruc")
'Lay dong cuoi va cot cuoi tren sheet LichTruc
rend = .Cells(Rows.Count, 3).End(xlUp).Row
cend = .Cells(3, Columns.Count).End(xlToLeft).Column
kq = .Range(Cells(3, 3), Cells(rend, cend)).Value
On Error Resume Next
ReDim data(1 To UBound(kq, 1), 1 To UBound(kq, 2))
For i = 1 To UBound(kq, 1) 'Duyet qua tung dong cua mang data()
data(i, 1) = kq(i, 1) 'cot A chua ngay thang
Next i
For j = 1 To UBound(kq, 2) 'Duyet qua tung cot cua mang data()
data(1, j) = kq(1, j) 'dong A1 chua thong tin can lay
Next j
ReDim arr(1 To UBound(kq, 1), 1 To 1)
k = 1
For d = k To UBound(kq, 2)
If kq(i, j) = "Ði làm" Then
arr(d, j) = data(1, j)
End If
Next d
.Range("O4:O" & rend).ClearContents
.Range("O4").Value = arr

End With
End Sub
 
thierry henry đã viết:
dạ không là cái này ạ

Sub Lichtruc8()
Dim cend As Long, arr As Variant, i As Long, j As Long, data As Variant, kq As Variant
Dim rend As Long, d As Long, k
With Sheets("LichTruc")
'Lay dong cuoi va cot cuoi tren sheet LichTruc
rend = .Cells(Rows.Count, 3).End(xlUp).Row
cend = .Cells(3, Columns.Count).End(xlToLeft).Column
kq = .Range(Cells(3, 3), Cells(rend, cend)).Value
On Error Resume Next
ReDim data(1 To UBound(kq, 1), 1 To UBound(kq, 2))
For i = 1 To UBound(kq, 1) 'Duyet qua tung dong cua mang data()
data(i, 1) = kq(i, 1) 'cot A chua ngay thang
Next i
For j = 1 To UBound(kq, 2) 'Duyet qua tung cot cua mang data()
data(1, j) = kq(1, j) 'dong A1 chua thong tin can lay
Next j
ReDim arr(1 To UBound(kq, 1), 1 To 1)
k = 1
For d = k To UBound(kq, 2)
If kq(i, j) = "Ði làm" Then
arr(d, j) = data(1, j)
End If
Next d
.Range("O4:O" & rend).ClearContents
.Range("O4").Value = arr

End With
End Sub
Nhấp chuột vào đây để mở rộng...
Code này có phải của tôi đâu bạn. Sao lại trích dẫn bài của tôi và nói là "em đã thử nhưng code của anh chị không cho ra kết quả".
 
huuthang_bd đã viết:
Code này có phải của tôi đâu bạn. Sao lại trích dẫn bài của tôi và nói là "em đã thử nhưng code của anh chị không cho ra kết quả".
Nhấp chuột vào đây để mở rộng...
Tôi ngỡ bạn dừng ở bài #47 rồi.
Bạn chăm lo chữ "nhẫn" của mình quá nên người ta cứ làm tới, tin rằng có thể lợi dụng.
 
huuthang_bd đã viết:
Code này có phải của tôi đâu bạn. Sao lại trích dẫn bài của tôi và nói là "em đã thử nhưng code của anh chị không cho ra kết quả".
Nhấp chuột vào đây để mở rộng...
dạ hình như em quên đưa code lên nên khúc đó anh hiểu nhầm ý em . em nói là code của anh chạy không ra kết quả . nên em mạo muội mò mẫm viết code khác , code chạy nhưng không ra kết quả và nhờ anh sửa bài giúp . có vậy thôi ạ . dù gì em cũng xin cảm ơn
 
VetMini đã viết:
Tôi ngỡ bạn dừng ở bài #47 rồi.
Bạn chăm lo chữ "nhẫn" của mình quá nên người ta cứ làm tới, tin rằng có thể lợi dụng.
Nhấp chuột vào đây để mở rộng...
Dừng không tham gia code thôi bác.
thierry henry đã viết:
dạ hình như em quên đưa code lên nên khúc đó anh hiểu nhầm ý em . em nói là code của anh chạy không ra kết quả . nên em mạo muội mò mẫm viết code khác , code chạy nhưng không ra kết quả và nhờ anh sửa bài giúp . có vậy thôi ạ . dù gì em cũng xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Bạn viết như thế này và tôi hiểu là bạn copy code ở bài 42 về chạy thử nhưng không ra kết quả. Như thế thì nhầm chỗ nào bạn. :rolleyes:
 
huuthang_bd đã viết:
Dừng không tham gia code thôi bác.

Bạn viết như thế này và tôi hiểu là bạn copy code ở bài 42 về chạy thử nhưng không ra kết quả. Như thế thì nhầm chỗ nào bạn. :rolleyes:
Nhấp chuột vào đây để mở rộng...
Dạ thưa các anh chị , em vừa lấy file nguyên thủy chạy thử thì chạy được . Vì file của em đã có nhiều sửa chữa và thử nghiệm nên có lẽ chạy không được . em xin lỗi ạ .
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

Mewwo98
Thay dấu ngăn cách sau chữ số hàng nghìn, hàng triệu, hàng tỷ trong Mail Merge
Trả lời
2
Đọc
43
ptm0412
ptm0412
ptm0412
  • Question Question
Lấy dữ liệu web nhiều trang về file Excel bằng Power Query
    • Thích
Trả lời
5
Đọc
2K
ptm0412
ptm0412
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
309
Đọc
23K
ongke0711
ongke0711
H
Công thức tìm kết quả
Trả lời
11
Đọc
101
VetMini
V
V
Hàm dò tìm lấy giá trị của lần xuất hiện thứ n trong excel.
Trả lời
9
Đọc
1K
VetMini
V
Huyen9
Lỗi không mailings được.
Trả lời
2
Đọc
46
Huyen9
Huyen9
N
Nhờ các anh chỉ chỉnh lỗi giúp em với ạ, em cảm ơn ạ.
Trả lời
3
Đọc
68
minhminh27
minhminh27
T
File quản lý thiết bị trong trường học!
Trả lời
4
Đọc
123
VetMini
V
Xoainon3005
Xin file mẫu kế hoạch sản xuất theo tháng ngành động cơ
Trả lời
1
Đọc
118
VetMini
V
Momominh
Sơ đồ hàng hóa trong Container
Trả lời
3
Đọc
115
VetMini
V
L
Viết phần mềm đánh lô bằng Visual Basic
    • Thích
2 3
Trả lời
51
Đọc
103K
taimeanh
T
hungtin1997
  • Question Question
[Hỏi] Tạo Hyperlink đến ô chạy ngang theo cột
Trả lời
6
Đọc
405
A HOANG 620
A
LuuAnh980
Add in tạo QR code miễn phí.
Trả lời
14
Đọc
544
htin1997
htin1997
tramcannt
Các bác cho hỏi làm cách nào để thu nhỏ thanh công thức này với ạ. Em cảm ơn.
Trả lời
2
Đọc
56
Nhattanktnn
Nhattanktnn
S
  • Question Question
Điều chỉnh kích thước dòng tự động theo trang in
Trả lời
5
Đọc
140
HUONGHCKT
H
A
Tạo vé Loto bằng Excel
2
Trả lời
20
Đọc
23K
Tuấn tata
Tuấn tata
Nauduong
Cách chuyển định dạng từ PDF sang Image
Trả lời
9
Đọc
262
Châu Bá Thông
Châu Bá Thông
minhduongct
  • Question Question
Viết code VBA thay cho dùng hàm vlookup
Trả lời
6
Đọc
1K
VetMini
V
N
Thử viết code lập trình đa luồng bằng TwinBasic và khả năng ứng dụng vào COM add-in chạy trong Excel
    • Thích
Trả lời
0
Đọc
170
nguyendang95
N
Thanh271188
Tìm giá trị xuất hiện bất kì (không phải giá trị đầu, cuối) trong excel
    • Cười
Trả lời
4
Đọc
224
Duy Tùng 9x
Duy Tùng 9x
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới Ất Tỵ 2025
Back
Top Bottom