Báo lỗi khi nhập vượt mức quy định

[vanlinh_2904]

Chào các Anh/Chị
Em nhờ anh chị viết giúp em VBA để mỗi khi nhập liệu nếu mỗi nhân viên trong cùng 1 ngày có số tiền chi vượt quá mức quy định thì báo lỗi.
Em cảm ơn các anh/chị.

 

[batman1]

1. Dòng 7-11 ( ngoài vùng dán) sẽ không bị xóa, chỉ xét xóa từ 4-6 ( trong vùng dán) thứ tự xét lần lượt dòng 4 đến dòng 6 :
- Nếu ( dòng 4 + ngoài vùng dán) > mức quy định => thì xóa dòng 4, 5, 6;
- Nếu (dòng 4 + ngoài vùng dán ) < mức quy định =>thì xét đến dòng 5, nếu ( dòng 5+ dòng 4 + ngoài vùng dán ) > mức quy định thì xóa dòng 5-6.
2. Số liệu ngoài vùng dán phải cố định không được xóa ( vì xóa thì mức còn lại sau mỗi lần nhập sẽ bị thay đổi liên tục khi đó số liệu sẽ bị xóa liên tục)

Thì tôi viết rõ mà, chỉ là đoán mò thôi. Bạn có mô tả hết các trường hợp đâu mà muốn người khác viết code. Không có bài của tôi thì riêng việc thống nhất cách xử lý cũng phải vài bài nữa. Vì thế tôi không tham gia. Tôi chỉ "giao lưu" với người khác thôi.

Phải mô tả hết các trường hợp, chi tiết, và rõ ràng, kiểu huỵch toẹt ra, không còn chỗ nào phải đoán mò, ngầm hiểu.

 

[SA_DQ]

#17 & #20 là tác giả đang giao nhiệm vụ đó; Các bạn ráng mà làm ra cho xong đi, giời ạ!
Những mong đến #40 thì sẽ hoàn tất mọi iêu cầu!

Chúc các bác có những ngày cuối tuần vui vẻ & tràn đầy năng lượng!

 

[Nhattanktnn]

#17 & #20 là tác giả đang giao nhiệm vụ đó; Các bạn ráng mà làm ra cho xong đi, giời ạ!
Những mong đến #40 thì sẽ hoàn tất mọi iêu cầu!

Chúc các bác có những ngày cuối tuần vui vẻ & tràn đầy năng lượng!

Lúc đầu em cũng không để ý, nhưng đến bác nói thì em có cảm giác như là đang giao việc thật. Nhưng thôi em cũng không quan tâm lắm, vì thấy cũng trả lời vào trọng tâm câu hỏi.

1. Dòng 7-11 ( ngoài vùng dán) sẽ không bị xóa, chỉ xét xóa từ 4-6 ( trong vùng dán) thứ tự xét lần lượt dòng 4 đến dòng 6 :
- Nếu ( dòng 4 + ngoài vùng dán) > mức quy định => thì xóa dòng 4, 5, 6;
- Nếu (dòng 4 + ngoài vùng dán ) < mức quy định =>thì xét đến dòng 5, nếu ( dòng 5+ dòng 4 + ngoài vùng dán ) > mức quy định thì xóa dòng 5-6.
2. Số liệu ngoài vùng dán phải cố định không được xóa ( vì xóa thì mức còn lại sau mỗi lần nhập sẽ bị thay đổi liên tục khi đó số liệu sẽ bị xóa liên tục)

Bạn dán code này vào module sheet1, chạy thử xem có vấn đề gì không:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("B5:D" & Rows.Count)) Is Nothing Then
    Static Dic As Object
    Dim sArr(), Arr(), Lr&, I&, iKey$, Str$
    Const iMax# = 1000000#, N$ = vbNullString
    If Dic Is Nothing Then Set Dic = CreateObject("Scripting.Dictionary") Else Dic.RemoveAll
    Lr = Cells(Rows.Count, "B").End(xlUp).Row
    sArr = Range("B5:D" & Lr).Value2
    Arr = Range(Cells(Target.Row, "B"), Cells(Target.Rows(Target.Rows.Count).Row, "D")).Value2
    For I = 1 To UBound(sArr)
        iKey = sArr(I, 1) & "|" & sArr(I, 2)
        Dic(iKey) = Dic(iKey) + sArr(I, 3)
    Next
    For I = UBound(Arr) To 1 Step -1
        iKey = Arr(I, 1) & "|" & Arr(I, 2)
        If Dic(iKey) > iMax Then
            If InStr(1, Str, Arr(I, 1), 1) = 0 Then
                Str = Str & vbNewLine & "NhanVien: " & Arr(I, 1)
            End If
            Dic(iKey) = Dic(iKey) - Arr(I, 3)
            Arr(I, 1) = N: Arr(I, 2) = N: Arr(I, 3) = N
        End If
    Next
    Cells(Target.Row, "B").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
    If Len(Str) Then
        Str = "Cac ma sau khong thoa man, da xoa: " & Str
        MsgBox "Xong! " & Str
    End If
End If
Application.EnableEvents = True
End Sub

 

[vanlinh_2904]

Lúc đầu em cũng không để ý, nhưng đến bác nói thì em có cảm giác như là đang giao việc thật. Nhưng thôi em cũng không quan tâm lắm, vì thấy cũng trả lời vào trọng tâm câu hỏi.

Bạn dán code này vào module sheet1, chạy thử xem có vấn đề gì không:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("B5:D" & Rows.Count)) Is Nothing Then
    Static Dic As Object
    Dim sArr(), Arr(), Lr&, I&, ShowMsg As Boolean, iKey$, Str$
    Const iMax# = 1000000#, N$ = vbNullString
    If Dic Is Nothing Then Set Dic = CreateObject("Scripting.Dictionary") Else Dic.RemoveAll
    Lr = Cells(Rows.Count, "B").End(xlUp).Row
    sArr = Range("B5:D" & Lr).Value2
    Arr = Range(Cells(Target.Row, "B"), Cells(Target.Rows(Target.Rows.Count).Row, "D")).Value2
    For I = 1 To UBound(sArr)
        iKey = sArr(I, 1) & "|" & sArr(I, 2)
        Dic(iKey) = Dic(iKey) + sArr(I, 3)
    Next
    For I = UBound(Arr) To 1 Step -1
        iKey = Arr(I, 1) & "|" & Arr(I, 2)
        If Dic(iKey) > iMax Then
            If InStr(1, Str, Arr(I, 1), 1) = 0 Then
                Str = Str & vbNewLine & "NhanVien: " & Arr(I, 1)
            End If
            Dic(iKey) = Dic(iKey) - Arr(I, 3)
            Arr(I, 1) = N: Arr(I, 2) = N: Arr(I, 3) = N
        End If
        If Arr(I, 1) <> N And Arr(I, 2) <> N And Arr(I, 3) <> N Then ShowMsg = True
    Next
    Cells(Target.Row, "B").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
    If ShowMsg Or Len(Str) Then
        Str = "Cac ma sau khong thoa man, da xoa: " & Str
        MsgBox "Xong! " & Str
    End If
End If
Application.EnableEvents = True
End Sub

Mình chạy thấy không có mã nào bị xóa nhưng vẫn luôn hiện thông báo, còn về kết quả thì đúng rồi. Cảm ơn bạn nhé!

 

[Nhattanktnn]

Mình chạy thấy không có mã nào bị xóa nhưng vẫn luôn hiện thông báo, còn về kết quả thì đúng rồi. Cảm ơn bạn nhé!View attachment 280120

Hình như khúc đó tôi nghĩ cái gì không nhớ nữa mới thêm một khúc vào, đã sửa lại code xóa khúc đó nhé!

 

[vanlinh_2904]

Hình như khúc đó tôi nghĩ cái gì không nhớ nữa mới thêm một khúc vào, đã sửa lại code xóa khúc đó nhé!

Cảm ơn bạn rất nhiều.