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

[huuthang_bd]

cho xin đường dẫn ạ

Bài 22 ở đây nhé.

 

[huuthang_bd]

Em áp dụng vào thì khi tính tổng (thứ 7 và chủ nhật) thì không đều nhau

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:

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

 

[dangg]

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:

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

Em xin chân thành cảm ơn bác nhiều ạ!