Giúp code Kiểm tra dữ liệu trùng theo nhiều điều kiện!

Chia sẻ bởi:hands

★★★★★

‹ Giúp sửa code: Trích rút từ Tổng... Code lọc theo 4 điều kiện., gom... ›

Quảng cáo

Em chào thầy cô & anh chị!
Em có bài này chưa làm được, cụ thể như sau:
Kiểm tra các hóa đơn bị nhập trùng theo các điều kiện sau:
1/ Trùng ký hiệu hóa đơn (cột D) Và
2/ Trùng Số hoá đơn (cột E) Và
3/ Trùng Ngày, tháng, năm phát hành (cột F) và
4/ Trùng Mã số thuế người bán (cột H) và
5/ Trùng Tổng cộng (Cột N)
Nếu dòng nào trùng thì tô cell màu đỏ của dòng tương ứng của cột E
————–
Trong File em có làm ví dụ:
Dòng 18 và dòng 29 trùng nhau
Dòng 24 và dòng 34 trùng nhau
—————-
Vui lòng viết code trên Module, vì em còn fải kết hợp để chạy nhiều code khác
Đây là bảng Demo, thực tế là rất nhiều dòng
Em cảm ơn!
———–
P/s: Cái này, trước đây em có dùng công thức trong C.F cột E như sau
=IF($A18<>"";SUMPRODUCT(($D$18:$D$39=$D18)*($E$18:$E$39=$E18)*($F$18:$F$39=$F18)*($H$18:$H$39=$H18)*($N$18:$N$39=$N18))>1;FALSE)
Nay em muốn chuyển qua code!

Bạn dùng thử Code này nhé
Sub Cf()
    Dim Arr, i As Long, iR As Long
    Arr = Range("D18:N" & Range("D65536").End(3).Row)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(Arr, 1)
            If Not .exists(Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 5) & Arr(i, 11)) Then
                .Add Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 5) & Arr(i, 11), i + 17
            Else
                iR = .Item(Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 5) & Arr(i, 11))
                Range(Cells(iR, 4), Cells(iR, 14)).Font.ColorIndex = i
                Range(Cells(i + 17, 4), Cells(i + 17, 14)).Font.ColorIndex = i
            End If
        Next
    End With
End Sub

Phải thế này không?

Sub tomau()
Dim data(), i As Long, d1 As Object, d2 As Object, dk As String
data = Range([D18], [E65536].End(3)).Resize(, 11).Value
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
   For i = 1 To UBound(data)
      dk = data(i, 1) & data(i, 2) & data(i, 3) & data(i, 5) & data(i, 11)
      If Not d1.exists(dk) Then
         d1.Add dk, ""
      Else
         d2.Add dk, ""
      End If
   Next
   For i = 1 To UBound(data)
      dk = data(i, 1) & data(i, 2) & data(i, 3) & data(i, 5) & data(i, 11)
      If d2.exists(dk) Then
         Cells(i + 17, 5).Interior.ColorIndex = 3
      End If
   Next
End Sub

www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-code-ki%E1%BB%83m-tra-d%E1%BB%AF-li%E1%BB%87u-tr%C3%B9ng-theo-nhi%E1%BB%81u-%C4%91i%E1%BB%81u-ki%E1%BB%87n.77108/

Em cảm ơn hai anh, cái nào cũng tuyệt!
———————
Sắp chuyển sang năm mới, Em chúc hai anh cùng Gia quyến được nhiều Sức khỏe, An khang – Thịnh vượng!

Nếu không may ở giữa dữ liệu có vài dòng rổng thì coi như.. tèo (báo lỗi)
Mà sao phải 2 vòng lập và 2 Dic thế không biết

Nếu dùng 1 Dic và 1 vòng lặp thì bài 2 viết rồi. Nếu em viết lại lần nữa y chang như thế thì kỳ quá
Và với 2 vòng lặp và 2 Dic đúng là thừa quá xá.

Code bài 2 cũng chưa phải là tối ưu đâu. Để ý chổ này:

If Not .exists(Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 5) & Arr(i, 11)) Then
  .Add Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 5) & Arr(i, 11), i + 17
Else
 [COLOR=#0000cd] [B]iR = .Item(Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 5) & Arr(i, 11))
  Range(Cells(iR, 4), Cells(iR, 14)).Font.ColorIndex = i[/B][/COLOR]
[COLOR=#ff0000][B]  Range(Cells(i + 17, 4), Cells(i + 17, 14)).Font.ColorIndex = i[/B][/COLOR]
End If

Nếu 1 phần tử trùng có 2 lần thì như thế có thể chấp nhận. Trường hợp 1 phần tử trùng từ 3 lần trở lên thì khi ta tô màu cho thằng em vừa phát hiện trùng, đồng thời lại tô màu luôn cho thằng thứ nhất —> có phải là THỪA không?
Suy nghĩ xem sửa lại thế nào mới là tối ưu đây? (phát hiện cái nào, tô màu cái nấy, mắc mớ gì tô đi tô lại 1 tên hoài vậy?)
Ẹc… Ẹc…
—————–
Trong code trên thì dòng màu đỏ là thằng em vừa phát hiện, còn dòng code màu xanh là thằng em đã phát hiện trước đó (khi Add vào Dic)

Nếu…….1 Dic và 2 For thì có được hông?
Mỗi cell chỉ tô màu 1 lần.
Public Sub GPE()
Dim Dic As Object, Arr(), I As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
Arr = Range(, .End(xlUp)).Resize(, 11).Value
For I = 1 To UBound(Arr, 1)
If Arr(I, 1) <> "" Then
Tem = Arr(I, 1) & Arr(I, 2) & Arr(I, 3) & Arr(I, 5) & Arr(I, 11)
If Not Dic.Exists(Tem) Then
Dic.Add Tem, ""
Else
Dic.Item(Tem) = "hihi"
End If
End If
Next I
For I = 1 To UBound(Arr, 1)
Tem = Arr(I, 1) & Arr(I, 2) & Arr(I, 3) & Arr(I, 5) & Arr(I, 11)
If Dic.Item(Tem) = "hihi" Then
Cells(I + 17, 5).Interior.ColorIndex = 3
End If
Next I
Set Dic = Nothing
End Sub

Hổng biết tốc độ nó ra sao.
Híc!

Em nghĩ ra thế này nhưng lại thấy sao sao ấy, có lẽ còn chậm hơn tô màu đè lên cái đã tô vi tốn thêm 2 thao tác.

Sub tomau()
Dim data(), i As Long, d As Object, dk As String, r
data = Range([D18], [E65536].End(3)).Resize(, 11).Value
Set d = CreateObject("scripting.dictionary")
   For i = 1 To UBound(data)
      dk = data(i, 1) & data(i, 2) & data(i, 3) & data(i, 5) & data(i, 11)
      If Not d.exists(dk) Then
         d.Add dk, i + 17
      Else
         r = d.Item(dk): d.Item(dk) = 1
         If r <> 1 Then Cells(r, 5).Interior.ColorIndex = 3
         Cells(i + 17, 5).Interior.ColorIndex = 3
      End If
   Next
End Sub

Code của anh giống bài 2 dic của em trong bài số 3

Thử cái xem sao:

Sub Test()
  Dim Arr, aData, tmp, rng As Range, rTmp As Range
  Dim i As Long
  [COLOR=#0000cd]Set rng = Range("D18:N1000")[/COLOR]
  aData = rng.Value
  With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(aData, 1)
      [COLOR=#0000cd]Arr = Array(aData(i, 1), aData(i, 2), aData(i, 3), aData(i, 5), aData(i, 11))[/COLOR]
      tmp = Join(Arr, vbNullString)
      If Len(tmp) Then
        tmp = Join(Arr, vbBack)
        If Not .exists(tmp) Then
          .Add tmp, i
        Else
          With Intersect(rng, rng(i, 1).EntireRow)
            .Interior.ColorIndex = 6
            .Font.ColorIndex = 3
          End With
          [COLOR=#ff0000]If .Item(tmp) > 0 Then
            With Intersect(rng, rng(.Item(tmp), 1).EntireRow)
              .Font.ColorIndex = 3
              .Interior.ColorIndex = 6
            End With
            .Item(tmp) = 0
          End If[/COLOR]
        End If
      End If
    Next
  End With
End Sub

Các bạn để ý sẽ thấy:
– Về mặt "biểu diễn" code, nếu mai này người ta có thay đổi vùng dữ liệu, cùng lắm chỉ sửa lại 2 dòng màu xanh (tất cả chổ khác nó tự "theo")
– Về phần cải tiến: là chổ màu đỏ —> Khi .Item(…) mà >0 thì mới tô màu thằng trước đó, không thì thôi
– Về giải thuật: Lưu ý nếu chỉ nối chuổi bình thường sẽ không chắc thằng nào trùng thằng nào —> Ít nhất giữa chúng phải có 1 ký tự đặc biệt nào đó (code trên dùng ký tự vbBack)

Xin lỗi không nói rõ là mình viết theo "kiểu" của Quang Hải.
Nhưng vì Ndu nói… sao mà 2 dic, 2 vòng lặp… nên mình gom lại thành 1 dic chứ không có gì mới.

Tự nhiên nói xin lỗi là sao ta. Ý em là nếu viết kiểu đó thì sẽ bị anh NDU thọt cù lét nữa mà thôi.
Vậy là em phải nói xin lỗi lại rồi. Hic.

Hì hì…
Bị thọt thì chịu thôi. Tại mình chưa có cách nào duyệt qua từng cell để tô màu.
Nghĩ tới duyệt từng cell dùng hàm Countif của Excel, chắc bị "chém", tô màu lại cho em đầu tiên add Dic bên trên cũng bị "chém", 2 Dic cũng bị "chém"…. bớt 1 Dic dù bị "chém" chắc cũng nhẹ hơn.
Ẹc..

Thầy ơi cho em trả bài sau nhé, giờ này em phê quá ah. (Mới chỉ khoảng 3 lít Bear + 1/5 chai Gin).
Em sửa lại Code như thế này để loại trừ trường hợp trùng 3 lần trở lên. Cách tô màu trùng theo loại như thế này cũng có hạn chế vì số ColorIndex có giới hạn nếu số lượng trùng quá lớn thì gây lỗi. Chủ Topic có thể biến đổi cho phù hợp (ví dụn như tô 1 màu cho tất cả các loại trùng chẳng hạn)
Sub Cf()
    Dim Arr, i As Long, iR As String
    Arr = Range("D18:N" & Range("D65536").End(3).Row)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(Arr, 1)
            If Not .exists(Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 5) & Arr(i, 11)) Then
                .Add Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 5) & Arr(i, 11), i + 17
            Else
                iR = .Item(Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 5) & Arr(i, 11))
                If IsNumeric(iR) Then
                    Range(Cells(iR, 4), Cells(iR, 14)).Font.ColorIndex = iR
                    Range(Cells(i + 17, 4), Cells(i + 17, 14)).Font.ColorIndex = iR
                    .Item(Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 5) & Arr(i, 11)) = "*" & iR
                Else
                    Range(Cells(i + 17, 4), Cells(i + 17, 14)).Font.ColorIndex = Mid(iR, 2)
                End If
            End If
        Next
    End With
End Sub
Các thầy, các anh chỉ bảo như thế này chả mấy chốc e tiêm bộ quá qh. Cảm ơn Gpe, cảm ơn các thầy cô, các anh chị!

Thì có ai bắt bạn không được tô 1 màu đâu

Đoạn này:

If IsNumeric(iR) Then
  Range(Cells(iR, 4), Cells(iR, 14)).Font.ColorIndex = iR
  [COLOR=#ff0000]Range(Cells(i + 17, 4), Cells(i + 17, 14)).Font.ColorIndex[/COLOR] = iR
  .Item(Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 5) & Arr(i, 11)) = "*" & iR
Else
  [COLOR=#ff0000]Range(Cells(i + 17, 4), Cells(i + 17, 14)).Font.ColorIndex[/COLOR] = Mid(iR, 2)
End If

Bạn có thấy 2 dòng màu đỏ là y chang nhau không? Vậy cho vào If làm gì?
——————————–

Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 5) & Arr(i, 11)

Nối chuổi kiểu này.. không ăn!
Còn đoạn này:

.Add Arr(i, 1) & Arr(i, 2) & Arr(i, 3) & Arr(i, 5) & Arr(i, 11), [COLOR=#ff0000][B]i + 17[/B][/COLOR]

Sao cứ phải là i + 17 thế nhỉ? Rồi người ta Insert thêm 1 dòng hoặc xóa bớt 1 dòng thì phải vào cửa sổ lập trình sửa lại cả "rừng" chổ
——————————–
Bạn xem lại [URL='https://www.giaiphapexcel.com/forum/showthread.php?77108-Gi%C3%BAp-code-Ki%E1%BB%83m-tra-d%E1%BB%AF-li%E1%BB%87u-tr%C3%B9ng-theo-nhi%E1%BB%81u-%C4%91i%E1%BB%81u-ki%E1%BB%87n%21&p=474093#post474093']bài 10 tôi đã làm đấy

Dạ đoạn này em để bắt trường hợp trùng từ 3 lần trở lên thì không tô đè ô đầu tiên.
'—————————————————————————–
Đúng là em chưa đọc bài số 10. Giờ đọc kỹ lại thấy "tư duy lập trình" còn hạn chế quá, từ việc chỉ nghĩ "làm được yêu cầu" tới việc "tối ưu hóa", "dự đoán lỗi" và làm "Code tổng quát" … còn là quá trình học hỏi dài dài. Mong được các thầy cô chỉ dạy nhiều hơn nữa.

Ý tôi muốn nói là nếu như ta có đoạn code:

IF đ/k = True then
  [COLOR=#0000cd]Lệnh A[/COLOR]
  [COLOR=#ff0000]Lệnh B[/COLOR]
  [COLOR=#006400]Lệnh C[/COLOR]
Else
  [COLOR=#ff0000]Lệnh B[/COLOR]
End If

Trong đoạn code trên, Lệnh B sẽ thực thi dù điều kiện If đúng hay sai, vậy thôi cho nó ra ngoài cho hợp lý:

[COLOR=#ff0000]Lệnh B[/COLOR]
IF đ/k = True then
[COLOR=#0000cd]  Lệnh A
  [/COLOR][COLOR=#006400]Lệnh C[/COLOR]
End If

OK chứ?

www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-code-ki%E1%BB%83m-tra-d%E1%BB%AF-li%E1%BB%87u-tr%C3%B9ng-theo-nhi%E1%BB%81u-%C4%91i%E1%BB%81u-ki%E1%BB%87n.77108/