Tạo kế hoạch Bảo dưỡng tự động trong Excel

trungkiensrv · 19/9/23

Mình xin chào tất cả mọi người,
Mình có 1 vấn đề liên quan đến kế hoạch bảo dưỡng thiết bị bằng Excel mà đã đau đầu làm thủ công nhiều năm nay rồi nhiều khi sai sót linh tinh và mất quá nhiều thời gian.

Giờ mới nghĩ tới là đăng lên diễn đàn để nhờ các cao thủ Excel giúp đỡ.
Mình có 1 danh sách các thiết bị có yêu cầu bảo dưỡng định kỳ với tần suất bảo dưỡng Day/Month/3Month/6Month/12Month của từng thiết bị khác nhau như file gửi kèm.
Giờ mình cần lập kế hoạch bảo dưỡng của năm tiếp theo cho tất cả các máy sản xuất này với yêu cầu là chỉ cần nhập ngày bắt đầu triển khai KHBD. Sau đó Excel sẽ tự động tính toán các ngày bảo dưỡng tiếp theo căn cứ vào tần suất bảo dưỡng như ở trên (Như trong file ảnh ở Sheet2)

Ngoài ra sẽ làm thêm 1 sheet để filter các máy có kế hoạch bảo dưỡng trong thời gian từ ngày nào tới ngày nào khi cần

Đây là file mình rất cần và rất mong nhận được sự giúp đỡ của tất cả mọi người

Xin chân thành cảm ơn !

trungkiensrv · 22/9/23

bebo021999 đã viết:

Theo tôi thì chỉ cần 2 sheet là đủ:
Sheet "List": đăng ký danh sách và thông tin
Sheet "Filter": Nhấn nút filter xem kết quả.
Trong file bạn đang +30, 60,90,180,360 ngày... mình đề xuất định nghĩa lại là cùng ngày, nhưng sau 1,3,6,12 tháng (hàm DateAdd) thì chính xác hơn

PHP:

Option Explicit
Sub FilterList()
Dim lr&, i&, j&, k&, c&, rng, res(), arr()
Dim staD As Double, endD As Double, freq As Double
staD = Range("C2").Value: endD = Range("C3").Value
If staD > endD Then
    MsgBox "Ngay ket thuc phai lon hon ngay bat dau!"
    Exit Sub
End If
With Sheets("List")
    lr = .Cells(Rows.Count, "B").End(xlUp).Row
    rng = .Range("A2:G" & lr).Value
End With
ReDim arr(1 To UBound(rng), 1 To 7)
For i = 1 To UBound(rng)
    If rng(i, 4) = "Active" Then
        Select Case rng(i, 5)
            Case "Month"
                rng(i, 7) = 1
            Case "Day"
                rng(i, 7) = 0
            Case "3Month"
                rng(i, 7) = 3
            Case "6Month"
                rng(i, 7) = 6
            Case "12Month"
                rng(i, 7) = 12
        End Select
        k = k + 1
        For j = 1 To 7
            arr(k, j) = rng(i, j)
        Next
    End If
Next
ReDim res(1 To k + 2, 1 To (endD - staD + 1))
For j = 1 To UBound(res, 2)
    res(2, j) = staD + j - 1
    res(1, j) = Format(res(2, j), "ddd")
Next
For i = 1 To k
    c = 0
    If arr(i, 6) <= endD Then
        Do
            Debug.Print freq, staD, endD
            freq = IIf(arr(i, 5) = "Day", arr(i, 6) + c, DateAdd("m", c * arr(i, 7), arr(i, 6)))
            If freq >= staD And freq <= endD Then res(i + 2, freq - staD + 1) = "x"
            c = c + 1
        Loop Until freq >= endD
    End If
Next
Range("A7:ZZ100000").ClearContents
Range("A7").Resize(k, 7).Value = arr
Range("F5:ZZ6").ClearContents
Range("F5").Resize(UBound(res), UBound(res, 2)).Value = res
End Sub

Cảm ơn bạn rất nhiều Đây chính là file mà mình đang cần
Một lần nữa xin cảm ơn bạn đã giúp đỡ

trungkiensrv · 28/9/23

bebo021999 đã viết:

Theo tôi thì chỉ cần 2 sheet là đủ:
Sheet "List": đăng ký danh sách và thông tin
Sheet "Filter": Nhấn nút filter xem kết quả.
Trong file bạn đang +30, 60,90,180,360 ngày... mình đề xuất định nghĩa lại là cùng ngày, nhưng sau 1,3,6,12 tháng (hàm DateAdd) thì chính xác hơn

PHP:

Option Explicit
Sub FilterList()
Dim lr&, i&, j&, k&, c&, rng, res(), arr()
Dim staD As Double, endD As Double, freq As Double
staD = Range("C2").Value: endD = Range("C3").Value
If staD > endD Then
    MsgBox "Ngay ket thuc phai lon hon ngay bat dau!"
    Exit Sub
End If
With Sheets("List")
    lr = .Cells(Rows.Count, "B").End(xlUp).Row
    rng = .Range("A2:G" & lr).Value
End With
ReDim arr(1 To UBound(rng), 1 To 7)
For i = 1 To UBound(rng)
    If rng(i, 4) = "Active" Then
        Select Case rng(i, 5)
            Case "Month"
                rng(i, 7) = 1
            Case "Day"
                rng(i, 7) = 0
            Case "3Month"
                rng(i, 7) = 3
            Case "6Month"
                rng(i, 7) = 6
            Case "12Month"
                rng(i, 7) = 12
        End Select
        k = k + 1
        For j = 1 To 7
            arr(k, j) = rng(i, j)
        Next
    End If
Next
ReDim res(1 To k + 2, 1 To (endD - staD + 1))
For j = 1 To UBound(res, 2)
    res(2, j) = staD + j - 1
    res(1, j) = Format(res(2, j), "ddd")
Next
For i = 1 To k
    c = 0
    If arr(i, 6) <= endD Then
        Do
            Debug.Print freq, staD, endD
            freq = IIf(arr(i, 5) = "Day", arr(i, 6) + c, DateAdd("m", c * arr(i, 7), arr(i, 6)))
            If freq >= staD And freq <= endD Then res(i + 2, freq - staD + 1) = "x"
            c = c + 1
        Loop Until freq >= endD
    End If
Next
Range("A7:ZZ100000").ClearContents
Range("A7").Resize(k, 7).Value = arr
Range("F5:ZZ6").ClearContents
Range("F5").Resize(UBound(res), UBound(res, 2)).Value = res
End Sub

Chào bạn.
Mình rất cảm ơn bạn đã giúp đỡ viết code giúp mình
Sau khi chạy thử mình thử có một số thay đổi như yêu cầu trong cột G sheet "List"
Nhờ bạn kiểm tra và modify lại code giúp mình
Mình cảm ơn rất nhiều.

bebo021999 · 28/9/23

trungkiensrv đã viết:
Chào bạn.
Mình rất cảm ơn bạn đã giúp đỡ viết code giúp mình
Sau khi chạy thử mình thử có một số thay đổi như yêu cầu trong cột G sheet "List"
Nhờ bạn kiểm tra và modify lại code giúp mình
Mình cảm ơn rất nhiều.

Vẫn chưa hiểu.
Cụ thể chút: Kế hoạch bảo dưỡng nằm ở đâu? Lần kế tiếp nằm ở đâu?

trungkiensrv · 28/9/23

bebo021999 đã viết:
Vẫn chưa hiểu.
Cụ thể chút: Kế hoạch bảo dưỡng nằm ở đâu? Lần kế tiếp nằm ở đâu?

Kế hoạch Bảo dưỡng sẽ Filter theo thời gian ở sheet Filter bạn viết lần trước đó

trungkiensrv · 30/9/23

trungkiensrv đã viết:
Kế hoạch Bảo dưỡng sẽ Filter theo thời gian ở sheet Filter bạn viết lần trước đó

Bạn ơi có thời gian xem giúp mình case này với. Thanks

Phuong Nguyen3390 · 3/11/24

bebo021999 đã viết:

Theo tôi thì chỉ cần 2 sheet là đủ:
Sheet "List": đăng ký danh sách và thông tin
Sheet "Filter": Nhấn nút filter xem kết quả.
Trong file bạn đang +30, 60,90,180,360 ngày... mình đề xuất định nghĩa lại là cùng ngày, nhưng sau 1,3,6,12 tháng (hàm DateAdd) thì chính xác hơn

PHP:

Option Explicit
Sub FilterList()
Dim lr&, i&, j&, k&, c&, rng, res(), arr()
Dim staD As Double, endD As Double, freq As Double
staD = Range("C2").Value: endD = Range("C3").Value
If staD > endD Then
    MsgBox "Ngay ket thuc phai lon hon ngay bat dau!"
    Exit Sub
End If
With Sheets("List")
    lr = .Cells(Rows.Count, "B").End(xlUp).Row
    rng = .Range("A2:G" & lr).Value
End With
ReDim arr(1 To UBound(rng), 1 To 7)
For i = 1 To UBound(rng)
    If rng(i, 4) = "Active" Then
        Select Case rng(i, 5)
            Case "Month"
                rng(i, 7) = 1
            Case "Day"
                rng(i, 7) = 0
            Case "3Month"
                rng(i, 7) = 3
            Case "6Month"
                rng(i, 7) = 6
            Case "12Month"
                rng(i, 7) = 12
        End Select
        k = k + 1
        For j = 1 To 7
            arr(k, j) = rng(i, j)
        Next
    End If
Next
ReDim res(1 To k + 2, 1 To (endD - staD + 1))
For j = 1 To UBound(res, 2)
    res(2, j) = staD + j - 1
    res(1, j) = Format(res(2, j), "ddd")
Next
For i = 1 To k
    c = 0
    If arr(i, 6) <= endD Then
        Do
            Debug.Print freq, staD, endD
            freq = IIf(arr(i, 5) = "Day", arr(i, 6) + c, DateAdd("m", c * arr(i, 7), arr(i, 6)))
            If freq >= staD And freq <= endD Then res(i + 2, freq - staD + 1) = "x"
            c = c + 1
        Loop Until freq >= endD
    End If
Next
Range("A7:ZZ100000").ClearContents
Range("A7").Resize(k, 7).Value = arr
Range("F5:ZZ6").ClearContents
Range("F5").Resize(UBound(res), UBound(res, 2)).Value = res
End Sub

bác ơi em mở file mà bị lỗi VBA ạ

Hoàng Tuấn 868 · 3/11/24

Phuong Nguyen3390 đã viết:
bác ơi em mở file mà bị lỗi VBA ạ

Lỗi VBA nó có nhiều loại, không biết lỗi của bạn là loại gì. (Trong đó có loại nguyên nhân do đưa ảnh cưới lên hình đại diện đó)

Phuong Nguyen3390 · 3/11/24

Hoàng Tuấn 868 đã viết:
Lỗi VBA nó có nhiều loại, không biết lỗi của bạn là loại gì. (Trong đó có loại nguyên nhân do đưa ảnh cưới lên hình đại diện đó)

Đây bác ơi, hiện lên như vậy ạ

Hoàng Tuấn 868 · 3/11/24

Phuong Nguyen3390 đã viết:
View attachment 305248

Đây bác ơi, hiện lên như vậy ạ

Dịch dòng chữ trên thông báo và thực hiện theo thôi bạn.

Tạo kế hoạch Bảo dưỡng tự động trong Excel

trungkiensrv

Thành viên mới

File đính kèm

trungkiensrv

Thành viên mới

trungkiensrv

Thành viên mới

File đính kèm

bebo021999

Thành viên gạo cội

trungkiensrv

Thành viên mới

trungkiensrv

Thành viên mới

Phuong Nguyen3390

Thành viên mới

Hoàng Tuấn 868

Đăng ký hôm qua

Phuong Nguyen3390

Thành viên mới

Hoàng Tuấn 868

Đăng ký hôm qua

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

Đếm ngược thời gian

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