Xoá dòng trùng lặp dữ liệu trong nhiều cột (1 người xem)

[thungdols]

Em có vấn đề khó cần giải quyết gấp. Nếu mà làm bằng tay thì chắc là đến tết sang năm cung không xong nữa.
Mong các anh, các chị cao thủ ở GPE giúp giùm. EM chân thành cảm ơn.
PM: nội dung em đã ghi rỏ trong file đính kèm

 

[thaytu]

Bạn tải về xem thử

Đã chạy được nhưng có lẻ chưa hoàn hảo lắm, co them 1 ty thu cong nhung chac den 8/3 di voi ban gai duoc rui.

 

[SA_DQ]

Thêm một fương án để bạn dễ lựa chọn

Option Explicit
Sub DelRows()
 Dim lCol As Integer, lRw As Long, Jj As Integer
 Dim Rng As Range, Clls As Range, sRng As Range, dRng As Range
 Dim Cll As Range
 Dim MyAdd As String
 
 Sheet1.Select
 If WorksheetFunction.CountA(Cells) > 0 Then
   lRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
      SearchDirection:=xlPrevious).Row
   lCol = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
      SearchDirection:=xlPrevious).Column + 1
 End If
 Cells.Interior.ColorIndex = 0
 Columns("A:A").Insert Shift:=xlToRight
 [A1].Value = "=SUM(RC[1]:RC[12])"
 [A1].AutoFill Destination:=Range("A1:A" & lRw), Type:=xlFillDefault
 For Each Clls In Range("A1:A" & lRw)
   Set Rng = Range(Clls.Offset(1), Cells(lRw, 1))
   Set sRng = Rng.Find(Clls.Value, , xlValues, xlWhole)
   If Not sRng Is Nothing Then
      MyAdd = sRng.Address
      Do
         Jj = 0
         For Each Cll In Clls.Offset(, 1).Resize(, lCol - 1)
            If Cll.Value <> Cells(sRng.Row, Cll.Column).Value Then Exit For
            Jj = Jj + 1
         Next
         If Jj = lCol - 1 Then
            If dRng Is Nothing Then
               Set dRng = sRng
            Else
               Set dRng = Union(dRng, sRng)
            End If
         End If
         Set sRng = Rng.FindNext(sRng)
      Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
      If Not dRng Is Nothing Then
         dRng.EntireRow.Delete:             Set dRng = Nothing
         Clls.Resize(, lCol).Interior.ColorIndex = 34 + Clls.Row Mod 7
      End If
   End If
 Next Clls
 
 Columns("A:A").Delete
End Sub

 

[thungdols]

Đã chạy được nhưng có lẻ chưa hoàn hảo lắm, co them 1 ty thu cong nhung chac den 8/3 di voi ban gai duoc rui.

cám ơn bac đã giúp đỡ nhưng với vaif nghìn dòng thi làm thủ công như vậy thì chắc cũng ngỏm quá

 

[thungdols]

Option Explicit
Sub DelRows()
Dim lCol As Integer, lRw As Long, Jj As Integer
Dim Rng As Range, Clls As Range, sRng As Range, dRng As Range
Dim Cll As Range
Dim MyAdd As String

Sheet1.Select
If WorksheetFunction.CountA(Cells) > 0 Then
lRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
lCol = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column + 1
End If
Cells.Interior.ColorIndex = 0
Columns("A:A").Insert Shift:=xlToRight
[A1].Value = "=SUM(RC[1]:RC[12])"
[A1].AutoFill Destination:=Range("A1:A" & lRw), Type:=xlFillDefault
For Each Clls In Range("A1:A" & lRw)
Set Rng = Range(Clls.Offset(1), Cells(lRw, 1))
Set sRng = Rng.Find(Clls.Value, , xlValues, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
Jj = 0
For Each Cll In Clls.Offset(, 1).Resize(, lCol - 1)
If Cll.Value <> Cells(sRng.Row, Cll.Column).Value Then Exit For
Jj = Jj + 1
Next
If Jj = lCol - 1 Then
If dRng Is Nothing Then
Set dRng = sRng
Else
Set dRng = Union(dRng, sRng)
End If
End If
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
If Not dRng Is Nothing Then
dRng.EntireRow.Delete: Set dRng = Nothing
Clls.Resize(, lCol).Interior.ColorIndex = 34 + Clls.Row Mod 7
End If
End If
Next Clls

Columns("A:A").Delete
End Sub

Cám ơn bac Đây là sự lựa chọn tốt nhất hiện tại mà em có. Chân thành cám ơn Bác. Em rất hâm mộ nhân tài ở GPE đó là thần tượng của em. Xin chân thành cám ơn bác

 

[cadafi]

Nếu mà làm bằng tay thì chắc là đến tết sang năm cung không xong nữa.
Mong các anh, các chị cao thủ ở GPE giúp giùm. EM chân thành cảm ơn.

Yêu cầu này bạn có thể dùng chức năng Advance Filter sẵn có của excel là giải quyết được ngay! Đâu cần viết code đâu!
Nếu viết code thì cũng dùng Advance Filter thôi! Bạn thử code củ chuối sau xem nhé! Test thử với dữ liệu khoảng 30 ngàn dòng thử xem.

Sub RowDel()
Dim iC as Long, iCol As Long: iCol = ActiveCell.SpecialCells(xlLastCell).Column
With ActiveSheet
.[A1].EntireRow.Insert
For iC = 1 To iCol
.Cells(1, iC) = Chr(64 + iC)
Next iC
.UsedRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, iCol + 2), Unique:=True
.[A1].EntireRow.Delete
End With
End Sub

 

[dynamic503]

Bạn tải về xem thử

Đã chạy được nhưng có lẻ chưa hoàn hảo lắm, co them 1 ty thu cong nhung chac den 8/3 di voi ban gai duoc rui.

Sub Button1_Click()
'
' Button1_Click Macro
'

'
Columns("A:L").Select
Range("A4").Activate
ActiveSheet.Range("$A$1:$L$629").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, _
7, 8, 9, 10, 11, 12), Header:=xlNo
End Sub