Xóa trùng theo nhiều điều kiện ràng buộc

[AnhThu-1976]

Anh, chị & các bạn có cách nào giúp em thực hiện nhanh cho công việc sau:
Em mô tả công việc như sau:
Từ phần mềm sẽ đỗ ra số liệu như sheet 1 (từ cột A cho đến cột L), còn cột M, N, O là do em đặt ra để xử lý
Cột O (Đợt), ví dụ khoảng 9h00 AM sẽ sẽ kết xuất ra và đặt là đợt 1, và tiếp những lần sau đặt là 2, 3, ...
Yêu cầu của em là xóa trùng và giữ lại 1 và ưu tiên giữ lại cặp có số thứ tự của đợt nhỏ nhất (hoặc số thứ tự nhỏ nhất)
Ví dụ: Mã khách hàng: KBS trùng 4 lần, ta tiến hành xóa các cặp có số thứ tự lớn nhất là: 014; 005; 003, chỉ giữ lại cặp có số thứ tự nhỏ nhất là 001
Tương tự làm lần lượt cho các mã khách hàng khác (thực tế khách hàng khá nhiều)
Vì công việc này thực hiện hàng ngày, các anh chị viết giúp code để có thực hiện công việc nhanh và chính xác
Sau khi thực hiện code xong thì em muốn kết qủa như ở Sheet1(2)
Em xin cảm ơn!

 

[Ba Tê]

Anh, chị & các bạn có cách nào giúp em thực hiện nhanh cho công việc sau:
Em mô tả công việc như sau:
Từ phần mềm sẽ đỗ ra số liệu như sheet 1 (từ cột A cho đến cột L), còn cột M, N, O là do em đặt ra để xử lý
Cột O (Đợt), ví dụ khoảng 9h00 AM sẽ sẽ kết xuất ra và đặt là đợt 1, và tiếp những lần sau đặt là 2, 3, ...
Yêu cầu của em là xóa trùng và giữ lại 1 và ưu tiên giữ lại cặp có số thứ tự của đợt nhỏ nhất (hoặc số thứ tự nhỏ nhất)
Ví dụ: Mã khách hàng: KBS trùng 4 lần, ta tiến hành xóa các cặp có số thứ tự lớn nhất là: 014; 005; 003, chỉ giữ lại cặp có số thứ tự nhỏ nhất là 001
Tương tự làm lần lượt cho các mã khách hàng khác (thực tế khách hàng khá nhiều)
Vì công việc này thực hiện hàng ngày, các anh chị viết giúp code để có thực hiện công việc nhanh và chính xác
Sau khi thực hiện code xong thì em muốn kết qủa như ở Sheet1(2)
Em xin cảm ơn!

Không hiểu "nhiều điều kiện ràng buộc" là sao, bạn xem file này coi sao, tôi thấy sao làm vậy chứ bạn giải thích thì ... không hiểu.

 

[HieuCD]

Anh, chị & các bạn có cách nào giúp em thực hiện nhanh cho công việc sau:
Em mô tả công việc như sau:
Từ phần mềm sẽ đỗ ra số liệu như sheet 1 (từ cột A cho đến cột L), còn cột M, N, O là do em đặt ra để xử lý
Cột O (Đợt), ví dụ khoảng 9h00 AM sẽ sẽ kết xuất ra và đặt là đợt 1, và tiếp những lần sau đặt là 2, 3, ...
Yêu cầu của em là xóa trùng và giữ lại 1 và ưu tiên giữ lại cặp có số thứ tự của đợt nhỏ nhất (hoặc số thứ tự nhỏ nhất)
Ví dụ: Mã khách hàng: KBS trùng 4 lần, ta tiến hành xóa các cặp có số thứ tự lớn nhất là: 014; 005; 003, chỉ giữ lại cặp có số thứ tự nhỏ nhất là 001
Tương tự làm lần lượt cho các mã khách hàng khác (thực tế khách hàng khá nhiều)
Vì công việc này thực hiện hàng ngày, các anh chị viết giúp code để có thực hiện công việc nhanh và chính xác
Sau khi thực hiện code xong thì em muốn kết qủa như ở Sheet1(2)
Em xin cảm ơn!

Bạn quên điều kiện ngày ?

Sub GPE()
  Dim sArr(), Res()
  Dim i As Long, k As Long, sR As Long, j As Byte, sC As Byte
  Dim iKey As String
  With Sheets("Sheet1")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i < 26 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A26:L" & i).Value
    sR = UBound(sArr, 1): sC = UBound(sArr, 2)
  End With
 
  ReDim Res(1 To sR, 1 To sC)
  k = 1
  With CreateObject("Scripting.Dictionary")
    For i = 1 To sR Step 2
      iKey = sArr(i, 2) & "#" & sArr(i, 4) & "#" & sArr(i, 6) & "#" & sArr(i, 7) & "#" & sArr(i + 1, 7)
      If Not .Exists(iKey) Then
        .Add iKey, Empty
        For j = 1 To sC
          Res(k, j) = sArr(i, j)
          Res(k + 1, j) = sArr(i + 1, j)
        Next j
        k = k + 2
      End If
    Next i
  End With
  If k > 0 Then
    With Sheets("Sheet2")
      .Range("C26").Resize(k - 1).NumberFormat = "@"
      .Range("A26").Resize(k - 1, sC) = Res
    End With
  End If
End Sub

 

[AnhThu-1976]

Bạn quên điều kiện ngày ?

    With Sheets("Sheet2")
      .Range("C26").Resize(k - 1).NumberFormat = "@"
      .Range("A26").Resize(k - 1, sC) = Res
    End With

Cảm ơn bạn đã nhắc nhở, cho hỏi thêm mình muốn lấy Format màu hay định dạng được không?
Ví dụ mã khách hàng KBS (tô màu đỏ), IKD (tô màu xanh) ... ở sheet trước khi chạy code, khi chạy code xong thì nó vẫn định dạng như Sheet gốc không? cảm ơn bạn!

 

[HieuCD]

Cảm ơn bạn đã nhắc nhở, cho hỏi thêm mình muốn lấy Format màu hay định dạng được không?
Ví dụ mã khách hàng KBS (tô màu đỏ), IKD (tô màu xanh) ... ở sheet trước khi chạy code, khi chạy code xong thì nó vẫn định dạng như Sheet gốc không? cảm ơn bạn!

Do xét màu từng 2 dòng, nếu dữ liệu nhiều code sẽ chạy chậm

Sub GPE()
  Dim sArr(), Res()
  Dim i As Long, k As Long, sR As Long, j As Byte, sC As Byte, iColor As Byte
  Dim iKey As String
 
  Application.ScreenUpdating = False
  With Sheets("Sheet2")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 25 Then .Range("A26:L" & i).Clear
  End With
 
  With Sheets("Sheet1")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i < 26 Then
      MsgBox ("Khong co du lieu")
      Application.ScreenUpdating = True
      Exit Sub
    End If
    sArr = .Range("A26:L" & i).Value
    sR = UBound(sArr, 1): sC = UBound(sArr, 2)
  End With
 
  iColor = 2
  ReDim Res(1 To sR, 1 To sC + 1)
  With CreateObject("Scripting.Dictionary")
    For i = 1 To sR Step 2
      iKey = sArr(i, 2) & "#" & sArr(i, 4) & "#" & sArr(i, 6) & "#" & sArr(i, 7) & "#" & sArr(i + 1, 7)
      If Not .Exists(iKey) Then
        .Add iKey, Empty
        k = k + 2
        For j = 1 To sC
          If j = 3 Then
            Res(k - 1, j) = "'" & sArr(i, j)
            Res(k, j) = "'" & sArr(i + 1, j)
          Else
            Res(k - 1, j) = sArr(i, j)
            Res(k, j) = sArr(i + 1, j)
          End If
        Next j
        iKey = sArr(i, 4)
        If Not .Exists(iKey) Then
          If iColor = 5 Then
            iColor = iColor + 2
          ElseIf iColor = 14 Then
            iColor = 3
          Else
            iColor = iColor + 1
          End If
        End If
        .Add iKey, Empty
        Res(k - 1, sC + 1) = iColor
      End If
    Next i
  End With
  If k > 0 Then
    With Sheets("Sheet2")
      Sheets("Sheet1").Range("A26:L26").Copy
      .Range("A26").Resize(k, sC).PasteSpecial Paste:=xlPasteFormats
      Application.CutCopyMode = False
      .Range("A26").Resize(k, sC) = Res
      '.Range("D26").Resize(k).Font.Bold = True' Xét Font Bold
      For i = 1 To k Step 2
        .Cells(i + 25, 4).Resize(2).Font.ColorIndex = Res(i, sC + 1)
      Next i
    End With
  End If
  Application.ScreenUpdating = True
End Sub

 

[AnhThu-1976]

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