Code VBA báo trùng tên hàng hóa (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Rùa Con 1080

Thành Viên Sao Chép 2
Tham gia
4/5/16
Bài viết
351
Được thích
47
Giới tính
Nữ
Chào mọi người!!! Em có bảng nhập tên hàng hóa từ A3:A400. Em có tham khảo cách dùng validation (=CountIf($A$3:A3,A3)=1) nhưng chưa thỏa. Vì cách này chỉ đúng với Mã hàng hóa. Còn của em là tên hàng hóa ví dụ như Bột ngọt, Đường, Muối, tiêu, Bột Ngọt Loại 1, Bột Ngọt Loại 2,,,v,,v,v,v,, và nhiêù khi lỗi gỏ như Bột Ngọt Loại1(không có khoảng trắng gi7ua4 Loại và 1)
Em muốn nhờ Mọi người viết code dùm trong sự kiện Worksheet_Change.
Em xin cám Ơn.
 
Chào mọi người!!! Em có bảng nhập tên hàng hóa từ A3:A400. Em có tham khảo cách dùng validation (=CountIf($A$3:A3,A3)=1) nhưng chưa thỏa. Vì cách này chỉ đúng với Mã hàng hóa. Còn của em là tên hàng hóa ví dụ như Bột ngọt, Đường, Muối, tiêu, Bột Ngọt Loại 1, Bột Ngọt Loại 2,,,v,,v,v,v,, và nhiêù khi lỗi gỏ như Bột Ngọt Loại1(không có khoảng trắng gi7ua4 Loại và 1)
Em muốn nhờ Mọi người viết code dùm trong sự kiện Worksheet_Change.
Em xin cám Ơn.
Nếu không có khoảng trắng ở giữa và có khoảng trắng ở giữa có báo là trùng hay không?Mà có file mãu mới giúp được bạn ơi.
 
Upvote 0
Dạ em xin đưa file, mong các AC giúp đõ. Em có thấy sử dụng Trim để cắt khoảng trắng, có thể dùng Trim để cắt khoảng trăng được không ah??? Có khoảng trắng ở giữa và không có khoảng trắng ơ3 giữa đếu báo hết Anh ơi. Vì như Nước Tương Loại 1 và Nước Tương Loai1 đều giống nhau.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Dạ em xin đưa file, mong các AC giúp đõ. Em có thấy sử dụng Trim để cắt khoảng trắng, có thể dùng Trim để cắt khoảng trăng được không ah??? Có khoảng trắng ở giữa và không có khoảng trắng ơ3 giữa đếu báo hết Anh ơi. Vì như Nước Tương Loại 1 và Nước Tương Loai1 đều giống nhau.
'Loại 1' rất khác 'Loại1' . Năm 2013, tôi gặp tình huống này, cũng nhờ các sư phụ trên GPE nay pót lai ko biết giúp bạn được ko?!
 

File đính kèm

Upvote 0
Dạ em xin đưa file, mong các AC giúp đõ. Em có thấy sử dụng Trim để cắt khoảng trắng, có thể dùng Trim để cắt khoảng trăng được không ah??? Có khoảng trắng ở giữa và không có khoảng trắng ơ3 giữa đếu báo hết Anh ơi. Vì như Nước Tương Loại 1 và Nước Tương Loai1 đều giống nhau.
Bạn sử dụng code này thử xem.
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sCell As Range, k As Integer
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, [a3:a1000]) Is Nothing Then
[A3:A65000].Interior.Pattern = xlNone
   For Each sCell In Range("A3:A" & Range("A65000").End(xlUp).Row)
       If UCase(Replace(sCell.Value, " ", "")) = UCase(Replace(Target.Value, " ", "")) Then
            sCell.Interior.Color = 255
            If sCell.Address <> Target.Address Then k = k + 1
       End If
   Next
End If
If k = 0 Then Target.Interior.Pattern = xlNone
End Sub
 
Upvote 0
Anh giaiphap có thẻ chỉnh code để nhập trùng thì có msgBox" trung ten hang hoa - xin nhap lai" được không ah!!!!!
Cám ơn Anh.
 
Upvote 0
Anh giaiphap có thẻ chỉnh code để nhập trùng thì có msgBox" trung ten hang hoa - xin nhap lai" được không ah!!!!!
Cám ơn Anh.
vậy bạn sửa code thế này thử xem.
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sCell As Range
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, [a3:a1000]) Is Nothing Then
   For Each sCell In Range("A3:A" & Range("A65000").End(xlUp).Row)
       If UCase(Replace(sCell.Value, " ", "")) = UCase(Replace(Target.Value, " ", "")) Then
            If sCell.Address <> Target.Address Then
                MsgBox "Du lieu da bi trung, de nghi ban nhap lai"
                Application.EnableEvents = False
                Application.Undo
                Application.EnableEvents = True
                Exit Sub
            End If
       End If
   Next
End If
End Sub
 
Upvote 0
Đúng rối Anh giaiphap ơi. Cám ơn Anh nhiều!!!!!!!
 
Upvote 0
Anh giaiphap cho em hỏi tí(có gì mong Anh bỏ qua). Nếu vừa có màu đỏ vừa có msgBox thì code làm sao hả Anh????
 
Upvote 0
Em có thêm vào code
Mã:
[COLOR=#000000]Private Sub Worksheet_Change(ByVal Target As Range)[/COLOR]Dim sCell As Range
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, [a3:a1000]) Is Nothing Then
   For Each sCell In Range("A3:A" & Range("A65000").End(xlUp).Row)
       If UCase(Replace(sCell.Value, " ", "")) = UCase(Replace(Target.Value, " ", "")) Then
           [B][COLOR=#ff0000][FONT=Verdana]sCell.Interior.Color = 255    '<----them vao cho nay[/FONT][/COLOR][/B]
            If sCell.Address <> Target.Address Then
                MsgBox "Du lieu da bi trung, de nghi ban nhap lai"
                Application.EnableEvents = False
                [COLOR=#b22222][B]Application.Undo   <-----thi bi loi vang cho nay[/B][/COLOR]
                Application.EnableEvents = True
                Exit Sub
            End If
       End If
   Next
End If [COLOR=#000000]End Sub[/COLOR]
Mong Anh chỉ giáo!!!!!
 
Upvote 0
Em có thêm vào code
Mã:
[COLOR=#000000]Private Sub Worksheet_Change(ByVal Target As Range)[/COLOR]Dim sCell As Range
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, [a3:a1000]) Is Nothing Then
   For Each sCell In Range("A3:A" & Range("A65000").End(xlUp).Row)
       If UCase(Replace(sCell.Value, " ", "")) = UCase(Replace(Target.Value, " ", "")) Then
           [B][COLOR=#ff0000][FONT=Verdana]sCell.Interior.Color = 255    '<----them vao cho nay[/FONT][/COLOR][/B]
            If sCell.Address <> Target.Address Then
                MsgBox "Du lieu da bi trung, de nghi ban nhap lai"
                Application.EnableEvents = False
                [COLOR=#b22222][B]Application.Undo   <-----thi bi loi vang cho nay[/B][/COLOR]
                Application.EnableEvents = True
                Exit Sub
            End If
       End If
   Next
End If [COLOR=#000000]End Sub[/COLOR]
Mong Anh chỉ giáo!!!!!
Bạn sửa lại vầy thử xem.
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sCell As Range, kt As Boolean
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, [a3:a1000]) Is Nothing Then
kt = False
Cells.Interior.Pattern = xlNone
   For Each sCell In Range("A3:A" & Range("A65000").End(xlUp).Row)
       If UCase(Replace(sCell.Value, " ", "")) = UCase(Replace(Target.Value, " ", "")) And sCell.Address <> Target.Address Then
           sCell.Interior.Color = 255    '<----them vao cho nay
            If sCell.Address <> Target.Address Then
                kt = True
            End If
       End If
   Next
    If kt Then
                MsgBox "Du lieu da bi trung, de nghi ban nhap lai"
                Application.EnableEvents = False
                Target.Value = Empty
                Target.Select
                Application.EnableEvents = True
     End If
End If
End Sub
 
Upvote 0
Em chèn thêm đoạn code để khi xem cell trùng được tô màu thì nhấn OK của msgBox thì cell trùng lại trở lại cũ (không màu), nhưng lại lỗi. Mong Anh xem giúp
Mã:
[COLOR=#000000]Private Sub Worksheet_Change(ByVal Target As Range)[/COLOR]Dim sCell As Range, kt As Boolean
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, [a3:a1000]) Is Nothing Then
kt = False
Cells.Interior.Pattern = xlNone
   For Each sCell In Range("A3:A" & Range("A65000").End(xlUp).Row)
       If UCase(Replace(sCell.Value, " ", "")) = UCase(Replace(Target.Value, " ", "")) And sCell.Address <> Target.Address Then
           sCell.Interior.Color = 255    '<----them vao cho nay
            If sCell.Address <> Target.Address Then
                kt = True
            End If
       End If
   Next
    If kt Then
                MsgBox "Du lieu da bi trung, de nghi ban nhap lai"
                Application.EnableEvents = False
                [B][COLOR=#ff0000]s[FONT=Verdana]Cells.Interior.Pattern = xlNone  <---em  ch[/FONT]èn chổ này, nhưng lỗi[/COLOR][/B]
                Target.Value = Empty
                Target.Select
                Application.EnableEvents = True
     End If
End If [COLOR=#000000]End Sub[/COLOR]
 
Upvote 0
Em chèn thêm đoạn code để khi xem cell trùng được tô màu thì nhấn OK của msgBox thì cell trùng lại trở lại cũ (không màu), nhưng lại lỗi. Mong Anh xem giúp
Mã:
[COLOR=#000000]Private Sub Worksheet_Change(ByVal Target As Range)[/COLOR]Dim sCell As Range, kt As Boolean
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, [a3:a1000]) Is Nothing Then
kt = False
Cells.Interior.Pattern = xlNone
   For Each sCell In Range("A3:A" & Range("A65000").End(xlUp).Row)
       If UCase(Replace(sCell.Value, " ", "")) = UCase(Replace(Target.Value, " ", "")) And sCell.Address <> Target.Address Then
           sCell.Interior.Color = 255    '<----them vao cho nay
            If sCell.Address <> Target.Address Then
                kt = True
            End If
       End If
   Next
    If kt Then
                MsgBox "Du lieu da bi trung, de nghi ban nhap lai"
                Application.EnableEvents = False
                [B][COLOR=#ff0000]s[FONT=Verdana]Cells.Interior.Pattern = xlNone  <---em  ch[/FONT]èn chổ này, nhưng lỗi[/COLOR][/B]
                Target.Value = Empty
                Target.Select
                Application.EnableEvents = True
     End If
End If [COLOR=#000000]End Sub[/COLOR]
Cái chổ màu đỏ đó bạn hiểu tác dụng của nó không? chứ tôi thì thua bạn thật rồi.
 
Upvote 0
em hiểu nó làm cho cell được tô màu thành trắng(không màu) phải không Anh. Nếu có gì sai mong Anh bỏ qua. Mong ANh giúp sau khi xem xong cell được tô màu xong thì nhấn OK của msgBox thì cell đó trở về không màu.
 
Upvote 0
em hiểu nó làm cho cell được tô màu thành trắng(không màu) phải không Anh. Nếu có gì sai mong Anh bỏ qua. Mong ANh giúp sau khi xem xong cell được tô màu xong thì nhấn OK của msgBox thì cell đó trở về không màu.
Cái chổ tô màu đỏ đó là ô nào vậy bạn. Nếu là tất cả thì chỉ cần vầy là được.
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sCell As Range, kt As Boolean
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, [a3:a1000]) Is Nothing Then
kt = False
Cells.Interior.Pattern = xlNone
   For Each sCell In Range("A3:A" & Range("A65000").End(xlUp).Row)
       If UCase(Replace(sCell.Value, " ", "")) = UCase(Replace(Target.Value, " ", "")) And sCell.Address <> Target.Address Then
           sCell.Interior.Color = 255    '<----them vao cho nay
            If sCell.Address <> Target.Address Then
                kt = True
            End If
       End If
   Next
    If kt Then
                MsgBox "Du lieu da bi trung, de nghi ban nhap lai"
[COLOR=#ff0000][B]                Cells.Interior.Pattern = xlNone[/B][/COLOR]
                Application.EnableEvents = False
                Target.Value = Empty
                Target.Select
                Application.EnableEvents = True
     End If
End If
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Cám ơn Anh, em có thử thì thấy như sau:
1/ khi code chạy thì xóa hết màu của các cell trong sheet.(chỉ cần xóa A3:A1000)
2/ khi nhần OK của msgBox thì lỗi "424' Object riquired.
Mã:
[COLOR=#000000]Private Sub Worksheet_Change(ByVal Target As Range)
[/COLOR]Dim sCell As Range, kt As Boolean
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, [a3:a1000]) Is Nothing Then
kt = False
Cells.Interior.Pattern = xlNone
   For Each sCell In Range("A3:A" & Range("A65000").End(xlUp).Row)
       If UCase(Replace(sCell.Value, " ", "")) = UCase(Replace(Target.Value, " ", "")) And sCell.Address <> Target.Address Then
           sCell.Interior.Color = 255    '<----them vao cho nay
            If sCell.Address <> Target.Address Then
                kt = True
            End If
       End If
   Next
    If kt Then
                MsgBox "Du lieu da bi trung, de nghi ban nhap lai"
[COLOR=#ff0000][B]                Cells.Interior.Pattern = xlNone <-----bi loi vang cho nay[/B][/COLOR]
                Application.EnableEvents = False
                Target.Value = Empty
                Target.Select
                Application.EnableEvents = True
     End If
End If [COLOR=#000000]End Sub[/COLOR]
Mong Anh xem giúp!!!!!
 
Lần chỉnh sửa cuối:
Upvote 0
Cám ơn Anh, em có thử thì thấy như sau:
1/ khi code chạy thì xóa hết màu của các cell trong sheet.(chỉ cần xóa A3:A1000)
2/ khi nhần OK của msgBox thì lỗi "424' Object riquired.
Mã:
[COLOR=#000000]Private Sub Worksheet_Change(ByVal Target As Range)
[/COLOR]Dim sCell As Range, kt As Boolean
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, [a3:a1000]) Is Nothing Then
kt = False
Cells.Interior.Pattern = xlNone
   For Each sCell In Range("A3:A" & Range("A65000").End(xlUp).Row)
       If UCase(Replace(sCell.Value, " ", "")) = UCase(Replace(Target.Value, " ", "")) And sCell.Address <> Target.Address Then
           sCell.Interior.Color = 255    '<----them vao cho nay
            If sCell.Address <> Target.Address Then
                kt = True
            End If
       End If
   Next
    If kt Then
                MsgBox "Du lieu da bi trung, de nghi ban nhap lai"
[COLOR=#ff0000][B]                Cells.Interior.Pattern = xlNone <-----bi loi vang cho nay[/B][/COLOR]
                Application.EnableEvents = False
                Target.Value = Empty
                Target.Select
                Application.EnableEvents = True
     End If
End If [COLOR=#000000]End Sub[/COLOR]
Mong Anh xem giúp!!!!!
Sao mình chạy báo lỗi gì đâu nhĩ, bạn xem file. Nếu muốn không bị ảnh hưởng màu của những cột khác hãy sửa chổ màu đỏ.
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sCell As Range, kt As Boolean
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, [a3:a1000]) Is Nothing Then
kt = False
[COLOR=#ff0000][B]Range("A3:A1000")[/B][/COLOR].Interior.Pattern = xlNone
   For Each sCell In Range("A3:A" & Range("A65000").End(xlUp).Row)
       If UCase(Replace(sCell.Value, " ", "")) = UCase(Replace(Target.Value, " ", "")) [COLOR=#000000][I]And sCell.Address <> Target.Address [/I][/COLOR]Then
           sCell.Interior.Color = 255
            If sCell.Address <> Target.Address Then
                kt = True
            End If
       End If
   Next
    If kt Then
                MsgBox "Du lieu da bi trung, de nghi ban nhap lai"
                [COLOR=#ff0000][B]Range("A3:A1000")[/B][/COLOR].Interior.Pattern = xlNone
                Application.EnableEvents = False
                Target.Value = Empty
                Target.Select
                Application.EnableEvents = True
     End If
End If
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Thế còn chỉ cần xóa những cell trùng trong cột A thôi, mong Anh giúp. Em đưa bài lên thì thấy Anh đã trả lời. Thật Cám Ơn Anh nhiều!!!!!!
 
Lần chỉnh sửa cuối:
Upvote 0
Anh coi dùm em file này sao bị lỗi vậy!!!!! Khi nhấn OK của msgBox thì lỗi vàng chổ:
Mã:
[B]Cells.Interior.Pattern = xlNone[/B]
Mong Anh xem giúp.....
 
Lần chỉnh sửa cuối:
Upvote 0
Anh coi dùm em file này sao bị lỗi vậy!!!!! Khi nhấn OK của msgBox thì lỗi vàng chổ:
Mã:
[B]Cells.Interior.Pattern = xlNone[/B]
Mong Anh xem giúp.....
Giữa file bạn đưa và code của bạn khác hoàn toàn, bạn thay bằng đoạn này.
Mã:
Range("A3:A1000").Interior.Pattern = xlNone
 
Upvote 0
A.giaiphap ơi giúp em nếu nhập tên hàng hóa trùng cả hai cột thì chỉnh code làm sao ah?????
ví dụ như hàng hóa "Dầu Oliu" nhập trùng "nhà cung cấp là "Anh Tuấn" thì báo lỗi dùm em Ah!!!! Đáng ra là nhà cung cấp là Anh Tính.
mong Anh giúp!!!!
 

File đính kèm

Upvote 0
A.giaiphap ơi giúp em nếu nhập tên hàng hóa trùng cả hai cột thì chỉnh code làm sao ah?????
ví dụ như hàng hóa "Dầu Oliu" nhập trùng "nhà cung cấp là "Anh Tuấn" thì báo lỗi dùm em Ah!!!! Đáng ra là nhà cung cấp là Anh Tính.
mong Anh giúp!!!!
Bạn thử đoạn code này
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sCell As Range, kt As Boolean, MyRang As Range
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, [a3:b1000]) Is Nothing Then
kt = False
Cells.Interior.Pattern = xlNone
   For Each sCell In Range("A3:A" & Range("A65000").End(xlUp).Row)
       If UCase(Replace(sCell.Value, " ", "")) = UCase(Replace(Target.Value, " ", "")) Then
           If MyRang Is Nothing Then
                Set MyRang = sCell
           Else
                Set MyRang = Union(MyRang, sCell)
           End If
           sCell.Interior.Color = 255
            If (sCell.Address <> Target.Address) And (sCell.Offset(, 2).Value = Target.Offset(, 2).Value) Then
                kt = True
            End If
       End If
   Next
    If kt Then
                MsgBox "Du lieu da bi trung, de nghi ban nhap lai"
                Cells.Interior.Pattern = xlNone
                Application.EnableEvents = False
                Target.Value = Empty
                Target.Select
                Application.EnableEvents = True
     ElseIf Not MyRang Is Nothing Then
            MyRang.Interior.Pattern = xlNone
     End If
End If
End Sub
 
Upvote 0
Sao em dán đoạn code của Anh vào không thấy báo gì hết vậy Anh????
Ý của em là khi nhập liệu trùng hai cột "Tên Hàng Hóa" (cột A) và "Nhà Cung Cấp"(Cột C) thì báo lỗi.
Mong Anh giúp.
 
Lần chỉnh sửa cuối:
Upvote 0
Anh giaiphap ơi, sao em dán đoạn code của Anh vào và thử sao không thấy báo trùng vậy Anh.
Mong ANH giúp đỡ.
 
Upvote 0
Anh giaiphap ơi, sao em dán đoạn code của Anh vào và thử sao không thấy báo trùng vậy Anh.
Mong ANH giúp đỡ.
Sửa thế này thử xem
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sCell As Range, kt As Boolean, MyRang As Range
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Union([a3:a1000], [c3:c1000])) Is Nothing Then
kt = False
Cells.Interior.Pattern = xlNone
  If Not Intersect(Target, [a3:a1000]) Is Nothing Then
   For Each sCell In Range("A3:A" & Range("A65000").End(xlUp).Row)
       If UCase(Replace(sCell.Value, " ", "")) = UCase(Replace(Target.Value, " ", "")) Then
           If MyRang Is Nothing Then
                Set MyRang = sCell
           Else
                Set MyRang = Union(MyRang, sCell)
           End If
            If (sCell.Address <> Target.Address) And (sCell.Offset(, 2).Value = Target.Offset(, 2).Value) Then
                sCell.Interior.Color = 255
                kt = True
            End If
       End If
   Next
  Else
   For Each sCell In Range("C3:C" & Range("C65000").End(xlUp).Row)
       If UCase(Replace(sCell.Value, " ", "")) = UCase(Replace(Target.Value, " ", "")) Then
           If MyRang Is Nothing Then
                Set MyRang = sCell
           Else
                Set MyRang = Union(MyRang, sCell)
           End If
           sCell.Interior.Color = 255
            If (sCell.Address <> Target.Address) And (sCell.Offset(, -2).Value = Target.Offset(, -2).Value) Then
                sCell.Interior.Color = 255
                kt = True
            End If
       End If
   Next
   End If
    If kt Then
                MsgBox "Du lieu da bi trung, de nghi ban nhap lai"
                Cells.Interior.Pattern = xlNone
                Application.EnableEvents = False
                Target.Value = Empty
                Target.Select
                Application.EnableEvents = True
     ElseIf Not MyRang Is Nothing Then
            MyRang.Interior.Pattern = xlNone
     End If
End If
End Sub
 
Upvote 0
Chào mọi người, trước em nhập liệu trên sheet,bây giờ em tập tành nhập liệu bằng Form, Mong mọi người giúp em khi nhập liệu bằng Form vào sheet, nếu trùng tên hàng hóa thì báo trùng(code trong Form em sưu tầm trên DD, và code Worksheet_Change của anh giaiphap)
 
Lần chỉnh sửa cuối:
Upvote 0
Trước mình đang modify dở cái này cho bên kho, nhưng các đồng chí ấy không hứng thú nên stop. bạn thử phát triển lại xem
 

File đính kèm

Upvote 0

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

Back
Top Bottom