Giúp xóa dữ liệu trùng

[BBmall]

Hiện mình cần xóa dữ liệu trùng nhau theo cách thủ công bằng hàm hay vba gì cũng được nhưng muốn xóa từ dưới lên tức là nếu trùng nhau thì hàng trên bị xóa đi còn hàng cuối để lại. Chỉ lọc dữ liệu trùng theo 1 cột

Và mình đang dùng code copy từ sheet2 nối vào sheet5. Ai có cách nào giúp mình thành copy từ sheet2 sang sheet5 nếu trùng (theo 1 cột) thì chép đè lên còn nếu không trùng thì nối vào. Nếu được cách này thì mình dùng và không dùng cách trên
Thanks và chúc mọi người ngày 08/03 nhiều niềm vui và hạnh phúc cùng gia đình, bạn bè

 

[snow25]

Hiện mình cần xóa dữ liệu trùng nhau theo cách thủ công bằng hàm hay vba gì cũng được nhưng muốn xóa từ dưới lên tức là nếu trùng nhau thì hàng trên bị xóa đi còn hàng cuối để lại. Chỉ lọc dữ liệu trùng theo 1 cột

Và mình đang dùng code copy từ sheet2 nối vào sheet5. Ai có cách nào giúp mình thành copy từ sheet2 sang sheet5 nếu trùng (theo 1 cột) thì chép đè lên còn nếu không trùng thì nối vào. Nếu được cách này thì mình dùng và không dùng cách trên
Cảm ơn và chúc mọi người ngày 08/03 nhiều niềm vui và hạnh phúc cùng gia đình, bạn bè

Cái nào để lọc trùng vậy.Cho ví dụ trùng ở cách 2 nào.

 

[BBmall]

Cái nào để lọc trùng vậy.Cho ví dụ trùng ở cách 2 nào.

Cột A bạn

 

[SA_DQ]

Và mình đang dùng code copy từ sheet2 nối vào sheet5. Ai có cách nào giúp mình thành copy từ sheet2 sang sheet5 nếu trùng (theo 1 cột) thì chép đè lên còn nếu không trùng thì nối vào. Nếu được cách này thì mình dùng và không dùng cách trên
Cảm ơn và chúc mọi người ngày 08/03 nhiều niềm vui và hạnh phúc cùng gia đình, bạn bè

Bạn thử trãi nghiệm & chỉnh sửa theo ý mình:

Sub CopyFromSheet2ToSheet5()
Dim Sh As Worksheet, Rng As Range, sRng As Range, Cls As Range
Dim Rws As Long, W As Integer, Col As Byte     '**'

With Sheet5.[A2]
    Rws = .CurrentRegion.Rows.Count
    Set Rng = .Resize(Rws)
    Col = .CurrentRegion.Rows.Count
    For Each Cls In Sheet2.Range(Sheet2.[A2], Sheet2.[A2].End(xlDown))
        Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
        If sRng Is Nothing Then                 'Chép Mói   '
            Rws = .End(xlDown).Row + 1
            Cls.Resize(, Col).Copy Destination:=.Cells(Rws, "A")
            .Cells(Rws, "A").Interior.ColorIndex = 35
        Else                                    'Chép Lên       '
            Cls.Resize(, Col).Copy Destination:=.Cells(sRng.Row, "A")
            .Cells(sRng.Row, "A").Interior.ColorIndex = 38
        End If
    Next Cls
End With
End Sub

 

[snow25]

Cột A bạn

Bạn xem code.

Sub chuyendulieu()
    Dim arr, arr1, arr2, lr As Long, a As Long, i As Long, j As Integer, dic As Object, dk As String, b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Lam hang")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr < 2 Then Exit Sub
         arr2 = .Range("A2:N" & lr).Value
    End With
    With Sheets("Data")
         lr = .Range("A2:" & "A" & Rows.Count).End(xlDown).Row
         arr = .Range("A3:N" & lr).Value
         ReDim arr1(1 To UBound(arr2, 1), 1 To 14)
         For i = 1 To UBound(arr, 1)
             dic.Item(arr(i, 1)) = i
         Next i
         For i = 1 To UBound(arr2, 1)
            b = dic.Item(arr2(i, 1))
            If b Then
               For j = 2 To 14
                   arr(b, j) = arr2(i, j)
               Next j
            Else
               a = a + 1
               For j = 1 To 14
                  arr1(a, j) = arr2(i, j)
               Next j
            End If
         Next i
         .Range("A3:N" & lr).Value = arr
         If a Then .Range("A" & lr + 1).Resize(a, 14).Value = arr1
    End With
End Sub

 

[BBmall]

@SA_DQ
Làm sao cho nó xóa hết định dạng và hàm k bạn ? Do mình không rành mấy cái này nên bạn thông cảm
@snow25
Vừa thử mà nó không hoạt động gì luôn

 

[snow25]

@SA_DQ
Làm sao cho nó xóa hết định dạng và hàm k bạn ? Do mình không rành mấy cái này nên bạn thông cảm
@snow25
Vừa thử mà nó không hoạt động gì luôn

Mình vẫn chạy được mà.Vẫn cập nhập tốt.Bạn test lại đi.Có khả năng nó ở cái dòng cuối cùng của dữ liệu 12000 dòng của bạn đó.Xem lại xem.Trước khi chạy code xóa hết những thứ vớ vẩn đi cho nó chạy đúng..

 

[BBmall]

Ngon rồi @snow25 . Thank bạn, @SA_DQ và diễn đàn GPE đã giúp mình

 

[kh0jy3n]

Hiện mình cần xóa dữ liệu trùng nhau theo cách thủ công bằng hàm hay vba gì cũng được nhưng muốn xóa từ dưới lên tức là nếu trùng nhau thì hàng trên bị xóa đi còn hàng cuối để lại. Chỉ lọc dữ liệu trùng theo 1 cột

Và mình đang dùng code copy từ sheet2 nối vào sheet5. Ai có cách nào giúp mình thành copy từ sheet2 sang sheet5 nếu trùng (theo 1 cột) thì chép đè lên còn nếu không trùng thì nối vào. Nếu được cách này thì mình dùng và không dùng cách trên
Cảm ơn và chúc mọi người ngày 08/03 nhiều niềm vui và hạnh phúc cùng gia đình, bạn bè

Nhờ thầy viết code cho toan bộ file đi cho nhẹ file @@.

 

[SA_DQ]

[QUOTE]Làm sao cho nó xóa hết định dạng và hàm k bạn ? Do mình không rành mấy cái này nên bạn thông cảm
[/QUOTE]
Biến dòng vừa chép không còn công thức:

Sub CopyFromSheet2ToSheet5()
Dim Sh As Worksheet, Rng As Range, sRng As Range, Cls As Range
Dim Rws As Long, W As Integer, Col As Byte

With Sheet5.[A2]
    Rws = .CurrentRegion.Rows.Count
    Set Rng = .Resize(Rws)
    Col = .CurrentRegion.Rows.Count
    For Each Cls In Sheet2.Range(Sheet2.[A2], Sheet2.[A2].End(xlDown))
        Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
        If sRng Is Nothing Then                 'Chép Mói   '
            Rws = .End(xlDown).Row + 1
            Cls.Resize(, Col).Copy Destination:=.Cells(Rws, "A")
            .Cells(Rws, "A").Resize(, Col).Value = .Cells(Rws, "A").Resize(, Col).Value     '*'
            .Cells(Rws, "A").Interior.ColorIndex = 35
        Else                                                'Chép Dè Lên       '
            Cls.Resize(, Col).Copy Destination:=.Cells(sRng.Row, "A")
            .Cells(sRng.Row, "A").Resize(, Col).Value = .Cells(sRng.Row, "A").Resize(, Col).Value   '*'
            .Cells(sRng.Row, "A").Interior.ColorIndex = 38
        End If
    Next Cls
End With
End Sub

 

[kh0jy3n]

[QUOTE]Làm sao cho nó xóa hết định dạng và hàm k bạn ? Do mình không rành mấy cái này nên bạn thông cảm

Biến dòng vừa chép không còn công thức:

Sub CopyFromSheet2ToSheet5()
Dim Sh As Worksheet, Rng As Range, sRng As Range, Cls As Range
Dim Rws As Long, W As Integer, Col As Byte

With Sheet5.[A2]
    Rws = .CurrentRegion.Rows.Count
    Set Rng = .Resize(Rws)
    Col = .CurrentRegion.Rows.Count
    For Each Cls In Sheet2.Range(Sheet2.[A2], Sheet2.[A2].End(xlDown))
        Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
        If sRng Is Nothing Then                 'Chép Mói   '
            Rws = .End(xlDown).Row + 1
            Cls.Resize(, Col).Copy Destination:=.Cells(Rws, "A")
            .Cells(Rws, "A").Resize(, Col).Value = .Cells(Rws, "A").Resize(, Col).Value     '*'
            .Cells(Rws, "A").Interior.ColorIndex = 35
        Else                                                'Chép Dè Lên       '
            Cls.Resize(, Col).Copy Destination:=.Cells(sRng.Row, "A")
            .Cells(sRng.Row, "A").Resize(, Col).Value = .Cells(sRng.Row, "A").Resize(, Col).Value   '*'
            .Cells(sRng.Row, "A").Interior.ColorIndex = 38
        End If
    Next Cls
End With
End Sub

[/QUOTE]
Thầy sao thầy viết được Vietkey trong Code ạ @@.

 

[snow25]

Biến dòng vừa chép không còn công thức:

Sub CopyFromSheet2ToSheet5()
Dim Sh As Worksheet, Rng As Range, sRng As Range, Cls As Range
Dim Rws As Long, W As Integer, Col As Byte

With Sheet5.[A2]
    Rws = .CurrentRegion.Rows.Count
    Set Rng = .Resize(Rws)
    Col = .CurrentRegion.Rows.Count
    For Each Cls In Sheet2.Range(Sheet2.[A2], Sheet2.[A2].End(xlDown))
        Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
        If sRng Is Nothing Then                 'Chép Mói   '
            Rws = .End(xlDown).Row + 1
            Cls.Resize(, Col).Copy Destination:=.Cells(Rws, "A")
            .Cells(Rws, "A").Resize(, Col).Value = .Cells(Rws, "A").Resize(, Col).Value     '*'
            .Cells(Rws, "A").Interior.ColorIndex = 35
        Else                                                'Chép Dè Lên       '
            Cls.Resize(, Col).Copy Destination:=.Cells(sRng.Row, "A")
            .Cells(sRng.Row, "A").Resize(, Col).Value = .Cells(sRng.Row, "A").Resize(, Col).Value   '*'
            .Cells(sRng.Row, "A").Interior.ColorIndex = 38
        End If
    Next Cls
End With
End Sub

Thầy sao thầy viết được Vietkey trong Code ạ @@.[/QUOTE]
Vẫn viết được mà có mỗi điều là 1 chữ không được quá 1 dấu.

 

[kh0jy3n]

Thầy sao thầy viết được Vietkey trong Code ạ @@.

Vẫn viết được mà có mỗi điều là 1 chữ không được quá 1 dấu.[/QUOTE]
Hi. Dạ vâng ạ

Em cảm ơn ạ !

 

[BBmall]

@snow25 : nếu cột A có cell trống mình bỏ qua thì làm sao bạn ? Vì vừa test cột A có cell trống nhưng B C D E có dữ liệu nó vẫn copy qua. Mình muốn A có cell trống nó không copy luôn các cột khác. Thanks bạn

 

[snow25]

@snow25 : nếu cột A có cell trống mình bỏ qua thì làm sao bạn ? Vì vừa test cột A có cell trống nhưng B C D E có dữ liệu nó vẫn copy qua. Mình muốn A có cell trống nó không copy luôn các cột khác. Cảm ơn bạn

Mình chưa Tests nhé.

Sub chuyendulieu()
    Dim arr, arr1, arr2, lr As Long, a As Long, i As Long, j As Integer, dic As Object, dk As String, b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Lam hang")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr < 2 Then Exit Sub
         arr2 = .Range("A2:N" & lr).Value
    End With
    With Sheets("Data")
         lr = .Range("A2:" & "A" & Rows.Count).End(xlDown).Row
         arr = .Range("A3:N" & lr).Value
         ReDim arr1(1 To UBound(arr2, 1), 1 To 14)
         For i = 1 To UBound(arr, 1)
             dic.Item(arr(i, 1)) = i
         Next i
         For i = 1 To UBound(arr2, 1)
         If arr2(i, 1) <> "" Then
            b = dic.Item(arr2(i, 1))
            If b Then
               For j = 2 To 14
                   arr(b, j) = arr2(i, j)
               Next j
            Else
               a = a + 1
               For j = 1 To 14
                  arr1(a, j) = arr2(i, j)
               Next j
            End If
         End If
         Next i
         .Range("A3:N" & lr).Value = arr
         If a Then .Range("A" & lr + 1).Resize(a, 14).Value = arr1
    End With
End Sub