Tự động điền thêm các ký tự trong ký hiệu hóa đơn

[Son-Thuy]

Mình nhờ các bạn giúp tự động điền thêm các ký tự trong ký hiệu hóa đơn (có phần trình bày trong file đính kèm)
Mục đích để giảm thiểu thời gian nhập liệu và tránh sai sót
Cảm ơn các bạn

 

[excel_lv1.5]

Mình nhờ các bạn giúp tự động điền thêm các ký tự trong ký hiệu hóa đơn (có phần trình bày trong file đính kèm)
Mục đích để giảm thiểu thời gian nhập liệu và tránh sai sót
Cảm ơn các bạn

Bạn dùng code này trong sự kiện Change của sheet

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [A1:A10000]) Is Nothing Then
    Application.EnableEvents = False
    Dim str As String: str = Target.Value
    With CreateObject("vbscript.regexp")
        .Pattern = "^[a-zA-Z]{2}(\/)?\d{2}([p,t,e,P,T,E])?$"
        If .test(Target) Then
            If .Execute(str)(0).submatches(0) = "" Then
                str = Mid(str, 1, 2) & "/" & Mid(str, 3)
            End If
            If .Execute(str)(0).submatches(1) = "" Then
                str = str & "E"
            End If
            Target = UCase(str)
        Else
            MsgBox "Nhap khong dung!"
            Target.Select
        End If
    End With
    Application.EnableEvents = True
End If
End Sub

 

[Son-Thuy]

Bạn dùng code này trong sự kiện Change của sheet

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [A1:A10000]) Is Nothing Then
    Application.EnableEvents = False
    Dim str As String: str = Target.Value
    With CreateObject("vbscript.regexp")
        .Pattern = "^[a-zA-Z]{2}(\/)?\d{2}([p,t,e,P,T,E])?$"
        If .test(Target) Then
            If .Execute(str)(0).submatches(0) = "" Then
                str = Mid(str, 1, 2) & "/" & Mid(str, 3)
            End If
            If .Execute(str)(0).submatches(1) = "" Then
                str = str & "E"
            End If
            Target = UCase(str)
        Else
            MsgBox "Nhap khong dung!"
            Target.Select
        End If
    End With
    Application.EnableEvents = True
End If
End Sub

Bạn ơi cho mình hỏi

Bạn dùng code này trong sự kiện Change của sheet

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [A1:A10000]) Is Nothing Then
    Application.EnableEvents = False
    Dim str As String: str = Target.Value
    With CreateObject("vbscript.regexp")
        .Pattern = "^[a-zA-Z]{2}(\/)?\d{2}([p,t,e,P,T,E])?$"
        If .test(Target) Then
            If .Execute(str)(0).submatches(0) = "" Then
                str = Mid(str, 1, 2) & "/" & Mid(str, 3)
            End If
            If .Execute(str)(0).submatches(1) = "" Then
                str = str & "E"
            End If
            Target = UCase(str)
        Else
            MsgBox "Nhap khong dung!"
            Target.Select
        End If
    End With
    Application.EnableEvents = True
End If
End Sub

Cảm ơn bạn nhiều
Code còn báo lỗi như sau
Nếu ta xóa một lúc vài ô trong cột A thì sẽ báo lỗi ở dòng
str = Target.Value
và sau khi reset thì code cũng không thể hoạt động được (nghĩa là nhập số liệu ở cột A xong & Enter thì số liệu đó không thay đổi, muốn hoạt động lại thì phải thoát khỏi excel, mở file lại thì mới hoạt động lại được

Bây giờ mình muốn bạn thay đổi code trên như sau: không dùng
Private Sub Worksheet_Change(ByVal Target As Range) mà chuyển nó về sub ... luôn
Khi chạy sub thì những ô bị lỗi thì sẽ được tô đỏ
Và code sẽ kiểm tra thêm ký tự thứ 4 và 5 sẽ là: 17; 18; 19; 20 ( đây là 2 số cuối của năm) nếu ký tự thứ 4 và 5 không thuộc những con số này thì cũng báo lỗi (tô màu đỏ)(tất nhiên qua năm 2021 thì code sẽ được bổ sung thêm số 21) (nếu trường hợp này bạn giúp được thì tốt không thì bỏ qua - vì để hạn chế nhập sai )
Mình muốn khi bị lỗi tô màu đỏ là vì có 1 số trường hợp đặt biệt sau:
Có 1 số chứng từ thì ký hiệu của nó là AA-19T (nghĩa là ký tự thứ 3 nó không phải là dấu /) khi đó mình cho qua
Xin các bạn viết giùm. Cảm ơn các bạn!

 

[huuthang_bd]

Đưa vào sub hay dùng thế nào tùy bạn.

Function KiemTra(ByVal sStr As String) As Boolean
If sStr Like "[A-Z][A-Z]/[0-9][0-9][A-Z]" Then
    KiemTra = Abs(((Year(Date) Mod 100) - 1.5) - Mid(sStr, 4, 2)) < 2
End If
End Function

 

[Son-Thuy]

Đưa vào sub hay dùng thế nào tùy bạn.

Function KiemTra(ByVal sStr As String) As Boolean
If sStr Like "[A-Z][A-Z]/[0-9][0-9][A-Z]" Then
    KiemTra = Abs(((Year(Date) Mod 100) - 1.5) - Mid(sStr, 4, 2)) < 2
End If
End Function

Cảm ơn bạn, cái này giúp mình kiểm tra nó đúng hay sai thôi
Ngoài ra thì mình không biết ứng dụng thêm như thế nào

 

[batman1]

Cho vào 1 module, vd. Module1

Private Sub KiemTraChinhSua(ByVal vung As Range)
'    kiem tra va tro giup nhap du lieu
Dim r As Long, c As Long, rng As Range, text As String, dulieu(), dit_thon As Object
    dulieu = vung.Resize(vung.Rows.Count + 1).Value ' lay du  1 dong o sau vung
    vung.Interior.ColorIndex = xlColorIndexNone ' xoa mau cu
    Set dit_thon = CreateObject("vbscript.regexp")
    With dit_thon
        .IgnoreCase = True
        .Pattern = "^[a-z]{2}/?(?:1[7-9]|20)[pte]?$"
    End With
    For r = 1 To UBound(dulieu, 1) - 1  ' khong xet dong lay du
        For c = 1 To UBound(dulieu, 2)
            text = Trim(dulieu(r, c))
            If Len(text) Then
                If dit_thon.test(text) Then ' neu o co dung dang <2 chu cai tu a-z><1 ky tu / hoac khong co><khong co ky tu nao hoac p, t, e>
                    If IsNumeric(Mid(text, Len(text))) Then text = text & "E"
                    If Mid(text, 3, 1) <> "/" Then text = Mid(text, 1, 2) & "/" & Mid(text, 3)
                    dulieu(r, c) = UCase(text)
                Else    ' nguoc lai thi cho vao tap cac cell can to mau
                    If rng Is Nothing Then
                        Set rng = vung.Parent.Cells(r + vung.Row - 1, c + vung.Column - 1)
                    Else
                        Set rng = Union(rng, vung.Parent.Cells(r + vung.Row - 1, c + vung.Column - 1))
                    End If
                End If
            End If
        Next c
    Next r
    vung.Value = dulieu ' nhap du lieu da chinh sua neu dung dang xuong sheet
    If Not rng Is Nothing Then rng.Interior.Color = RGB(255, 0, 0)  ' to mau cac o khong dung dang
    Set dit_thon = Nothing
End Sub

Sub kiemtra()
'    vi du kiem tra va chinh sua trong Sheet1!A2:A1000
    KiemTraChinhSua Sheet1.Range("A2:A1000")
End Sub

 

[batman1]

Đưa vào sub hay dùng thế nào tùy bạn.

Function KiemTra(ByVal sStr As String) As Boolean
If sStr Like "[A-Z][A-Z]/[0-9][0-9][A-Z]" Then
    KiemTra = Abs(((Year(Date) Mod 100) - 1.5) - Mid(sStr, 4, 2)) < 2
End If
End Function

Không đúng yêu cầu.
Các dữ liệu nhập sau đây đều hợp lệ nhưng hàm trả về FALSE:

ac20, ac/20, ac/20p, ac/20t, ab/20e, DH/18, DQ/17p, DZ/19

 

[Son-Thuy]

Cho vào 1 module, vd. Module1

Private Sub KiemTraChinhSua(ByVal vung As Range)
'    kiem tra va tro giup nhap du lieu
Dim r As Long, c As Long, rng As Range, text As String, dulieu(), dit_thon As Object
    dulieu = vung.Resize(vung.Rows.Count + 1).Value ' lay du  1 dong o sau vung
    vung.Interior.ColorIndex = xlColorIndexNone ' xoa mau cu
    Set dit_thon = CreateObject("vbscript.regexp")
    With dit_thon
        .IgnoreCase = True
        .Pattern = "^[a-z]{2}/?(?:1[7-9]|20)[pte]?$"
    End With
    For r = 1 To UBound(dulieu, 1) - 1  ' khong xet dong lay du
        For c = 1 To UBound(dulieu, 2)
            text = Trim(dulieu(r, c))
            If Len(text) Then
                If dit_thon.test(text) Then ' neu o co dung dang <2 chu cai tu a-z><1 ky tu / hoac khong co><khong co ky tu nao hoac p, t, e>
                    If IsNumeric(Mid(text, Len(text))) Then text = text & "E"
                    If Mid(text, 3, 1) <> "/" Then text = Mid(text, 1, 2) & "/" & Mid(text, 3)
                    dulieu(r, c) = UCase(text)
                Else    ' nguoc lai thi cho vao tap cac cell can to mau
                    If rng Is Nothing Then
                        Set rng = vung.Parent.Cells(r + vung.Row - 1, c + vung.Column - 1)
                    Else
                        Set rng = Union(rng, vung.Parent.Cells(r + vung.Row - 1, c + vung.Column - 1))
                    End If
                End If
            End If
        Next c
    Next r
    vung.Value = dulieu ' nhap du lieu da chinh sua neu dung dang xuong sheet
    If Not rng Is Nothing Then rng.Interior.Color = RGB(255, 0, 0)  ' to mau cac o khong dung dang
    Set dit_thon = Nothing
End Sub

Sub kiemtra()
'    vi du kiem tra va chinh sua trong Sheet1!A2:A1000
    KiemTraChinhSua Sheet1.Range("A2:A1000")
End Sub

Bạn cho hỏi sau này mình muốn mở rộng cho thứ 4 và 5 là 21;22; ... thì sửa code chỗ nào vậy
Xin cảm ơn bạn!

 

[batman1]

Bạn cho hỏi sau này mình muốn mở rộng cho thứ 4 và 5 là 21;22; ... thì sửa code chỗ nào vậy
Xin cảm ơn bạn!

.Pattern = "^[a-z]{2}/?(?:1[7-9]|2[0-2])[pte]?$"

Tức 17, 18, 19, 20, 21, 22

 

[huuthang_bd]

Không đúng yêu cầu.
Các dữ liệu nhập sau đây đều hợp lệ nhưng hàm trả về FALSE:

ac20, ac/20, ac/20p, ac/20t, ab/20e, DH/18, DQ/17p, DZ/19

Em viết cho yêu cầu ở bài #3. Theo em hiểu thì yêu cầu bài #3 chỉ đơn giản là kiểm tra dữ liệu có đúng định dạng chuẩn không, các trường hợp nêu trong bài #1 mà chưa sửa cũng là sai, cần phải sửa.

 

[Son-Thuy]

Xin cảm ơn các bạn giúp đỡ code đã chạy tốt!

 

[batman1]

Em viết cho yêu cầu ở bài #3. Theo em hiểu thì yêu cầu bài #3 chỉ đơn giản là kiểm tra dữ liệu có đúng định dạng chuẩn không, các trường hợp nêu trong bài #1 mà chưa sửa cũng là sai, cần phải sửa.

Nhìn code tôi biết bạn chỉ kiểm tra xem dữ liệu nào đó có đúng là <2 chữ cái a-z><ký tự /><17, 18,..., hoặc 20><p, t hoặc e> *** nên tôi không viết là SAI mà chỉ là "chưa đúng yêu cầu".

*** thực ra dữ liệu chuẩn chỉ được phép là p, t hoặc e ở cuối chứ không phải a-z.