Nhờ hỗ trợ xóa trùng kèm điều kiện

[nguyenhuy0706]

Em đang có 1 file danh sách muốn xóa trùng tại cột A kèm theo xóa dòng không có dữ liệu tại cột C (Em muốn dữ lại thông tin cột C nếu có thông tin trường hợp cả 2 dòng cột C cùng không có thì xóa dòng bất kỳ). Em đã đánh dấu trùng và xử dụng công cụ remove duplicates nhưng không thực hiện được theo nhu cầu. Nhờ a/c GPE hướng dẫn giúp em hướng xử lý. Tks

 

[snow25]

Em đang có 1 file danh sách muốn xóa trùng tại cột A kèm theo xóa dòng không có dữ liệu tại cột C (Em muốn dữ lại thông tin cột C nếu có thông tin trường hợp cả 2 dòng cột C cùng không có thì xóa dòng bất kỳ). Em đã đánh dấu trùng và xử dụng công cụ remove duplicates nhưng không thực hiện được theo nhu cầu. Nhờ a/c GPE hướng dẫn giúp em hướng xử lý. Tks

Đây bạn xem.

Sub xoadulieu()
Dim a As Long, i As Long, j As Long, lr As Long, b As Long
Dim arr, arr1
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheet1
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    arr = .Range("A1:E" & lr).Value
    ReDim arr1(1 To UBound(arr, 1), 1 To 5)
    For i = 1 To UBound(arr, 1)
        If Len(arr(i, 3)) > 0 Then
           If dic.exists(arr(i, 1)) = 0 Then
               dic.Item(arr(i, 1)) = "KK"
               a = a + 1
               For j = 1 To 5
                  arr1(a, j) = arr(i, j)
               Next j
           End If
       End If
   Next i
    b = .Range("H" & Rows.Count).End(xlUp).Row
     .Range("H1:L" & b).ClearContents
   If a Then .Range("H1").Resize(a, 5).Value = arr1
End With
End Sub

 

[HieuCD]

Em đang có 1 file danh sách muốn xóa trùng tại cột A kèm theo xóa dòng không có dữ liệu tại cột C (Em muốn dữ lại thông tin cột C nếu có thông tin trường hợp cả 2 dòng cột C cùng không có thì xóa dòng bất kỳ). Em đã đánh dấu trùng và xử dụng công cụ remove duplicates nhưng không thực hiện được theo nhu cầu. Nhờ a/c GPE hướng dẫn giúp em hướng xử lý. Tks

Thử code dài lê thê

Sub XoaTrung()
  Dim sArr(), Res(), iKey As String
  Dim i As Long, k As Long, ik As Long, eRow As Long, j As Byte
 
  With Sheets("Sheet 1")
    eRow = .Range("A1000000").End(xlUp).Row
    If eRow < 3 Then Exit Sub
    sArr = .Range("A1:E" & eRow).Value
  End With

  ReDim Res(1 To eRow, 1 To 5)
  With CreateObject("Scripting.Dictionary")
    For i = 2 To eRow
      iKey = CStr(sArr(i, 1))
      If Len(iKey) Then
        If Not .exists(iKey) Then
          If Len(sArr(i, 3)) = 0 Then .Add iKey, i Else .Add iKey, 0
        Else
          ik = .Item(iKey)
          If Len(sArr(i, 3)) > 0 And ik > 0 Then .Item(iKey) = 0 Else ik = i
          sArr(ik, 1) = "Xu Tram"
        End If
      End If
    Next i
  End With

  For i = 1 To eRow
    If sArr(i, 1) <> "Xu Tram" Then
      k = k + 1
      For j = 1 To 5
        Res(k, j) = sArr(i, j)
      Next j
    End If
  Next i
 
  Application.ScreenUpdating = False
  With Sheets("Sheet2")
    eRow = .Range("A1000000").End(xlUp).Row
    .Range("A1:E" & eRow).ClearContents
    If k Then
      .Range("A1:A" & k).NumberFormat = "@"
      .Range("A1:E" & k) = Res
    End If
  End With
  Application.ScreenUpdating = True
End Sub