CẦN LẤY DỮ LIỆU GẦN NHẤT - XÓA CÁC DỮ LIỆU TRÙNG NHAU

[myhiep1811]

Em chào anh/chị
Anh/ chị giúp em: em có một file excel dữ liệu trùng nhau rất nhiều lần. Em muốn lấy dữ liệu ngày gần nhất và xóa các dữ liệu trùng nhau.Thanks all

 

[Lê Duy Thương]

Em chào anh/chị
Anh/ chị giúp em: em có một file excel dữ liệu trùng nhau rất nhiều lần. Em muốn lấy dữ liệu ngày gần nhất và xóa các dữ liệu trùng nhau.Thanks all

dữ liệu lớn như thế này nên dung pivot table nhé

 

[Hamedanger]

Bài này mình thấy hay hay, nên thử xử lý bằng VBA. Hy vọng là đúng ý bạn ?
Sang Sheet KetQua chạy code xem thử.

Sub GPE()
Application.ScreenUpdating = False
Dim sRng As Range, iArr As Variant, endR As Long
Sheet2.Range("A2:E1048576").ClearContents
With Sheet1
endR = .Range("A1048576").End(3).Row
.Range("A2:E" & endR).Sort Key1:=.Range("A1"), order1:=xlAscending, _
Key2:=.Range("E1"), order2:=xlDescending, _
Header:=xlYes
iArr = .Range("A2:E" & endR).Value
End With

Dim oArr As Variant, Dic As Object, iDic As Variant, I As Long, J As Long, R As Long
Set Dic = CreateObject("Scripting.Dictionary")
For I = LBound(iArr, 1) To UBound(iArr, 1)
If Not Dic.exists(CStr(iArr(I, 1))) Then Dic.Add CStr(iArr(I, 1)), I
Next

If Dic.Count = 0 Then
Application.ScreenUpdating = True
Exit Sub
End If

ReDim oArr(1 To Dic.Count, 1 To 5)
iDic = Dic.items

For I = LBound(iDic, 1) To UBound(iDic, 1)
R = iDic(I)
For J = 1 To 5
oArr(I + 1, J) = iArr(R, J)
Next
Next

Sheet2.Range("A2").Resize(UBound(oArr, 1), 5) = oArr
Application.ScreenUpdating = True
End Sub

 

[Hoàng Nhật Phương]

Hic hic

Option Explicit
Sub Hic_HàNNôi_BanHànhCôngVan_GianCáchCovid_roi_BuonQuaaaaa_huhu()
    Dim dic As Object, data(), rng As Range, i As Long, j As Long, k As Long
    Set dic = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Worksheets("Sheet1")
        Set rng = .Cells(1, "A").CurrentRegion
        rng.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("E1"), Order2:=xlDescending, Orientation:=xlTopToBottom, Header:=xlYes
    End With
    data = rng.Value
    For i = 1 To UBound(data, 1)
        If Not dic.Exists(data(i, 1)) Then
            k = k + 1: dic.Add data(i, 1), k
            For j = 1 To UBound(data, 2)
                data(k, j) = data(i, j)
            Next j
        End If
    Next i
    With ThisWorkbook.Worksheets("KetQua").Cells(1, "A")
        .CurrentRegion.ClearContents
        If k Then .Resize(k, UBound(data, 2)).Value = data
    End With
End Sub

 

[Ba Tê]

Hic hic

Option Explicit
Sub Hic_HàNNôi_BanHànhCôngVan_GianCáchCovid_roi_BuonQuaaaaa_huhu()
    Dim dic As Object, data(), rng As Range, i As Long, j As Long, k As Long
    Set dic = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Worksheets("Sheet1")
        Set rng = .Cells(1, "A").CurrentRegion
        rng.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("E1"), Order2:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
    End With
    data = rng.Value
    For i = 1 To UBound(data, 1)
        If Not dic.Exists(data(i, 1)) Then
            k = k + 1: dic.Add data(i, 1), k
            For j = 1 To UBound(data, 2)
                data(k, j) = data(i, j)
            Next j
        End If
    Next i
    With ThisWorkbook.Worksheets("KetQua").Cells(1, "A")
        .CurrentRegion.ClearContents
        If k Then .Resize(k, UBound(data, 2)).Value = data
    End With
End Sub

Dữ liệu "nguyên xi" của người ta, đem đi Sort, nhìn lại "lạ hoắc" người ta có chịu không?
Đã xài Dic thì cứ cho nó lung tung cũng được mà.

Option Explicit

Sub GPE()
Const CoLs As Long = 5
Dim Dic As Object, sArr(), dArr(), Txt As String
Dim I As Long, J As Long, K As Long, R As Long, Rws As Long
Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = vbTextCompare
    sArr = Sheet1.Range("A1", Sheet1.Range("A1").End(xlDown)).Resize(, CoLs).Value
    R = UBound(sArr)
ReDim dArr(1 To R, 1 To CoLs)
    For I = 1 To R
        Txt = sArr(I, 1)
        If Not Dic.Exists(Txt) Then
            K = K + 1
            Dic.Item(Txt) = K
            For J = 1 To CoLs
                dArr(K, J) = sArr(I, J)
            Next J
        Else
            Rws = Dic.Item(Txt)
            If sArr(I, CoLs) > dArr(Rws, CoLs) Then
                dArr(Rws, 4) = sArr(I, 4)
                dArr(Rws, CoLs) = sArr(I, CoLs)
            End If
        End If
    Next I
    With Sheets("KetQua")
        .Range("A1:A100000").Resize(, CoLs).ClearContents
        If K Then Range("A1").Resize(K, CoLs).Value = dArr
    End With
Set Dic = Nothing
End Sub

 

[Hoàng Nhật Phương]

Dữ liệu "nguyên xi" của người ta, đem đi Sort, nhìn lại "lạ hoắc" người ta có chịu không?
Đã xài Dic thì cứ cho nó lung tung cũng được mà.

Option Explicit
Sub Hic_HàNNôi_BanHànhCôngVan_GianCáchCovid_roi_BuonQuaaaaa_huhu()
    Const CoLs As Long = 5
    Dim Dic As Object, Data(), KQ(), i As Long, j As Long, k As Long, R As Long, Rws As Long
    Set Dic = CreateObject("Scripting.Dictionary")
        Data = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown)).Resize(, CoLs).Value
        Rws = UBound(Data)
    ReDim KQ(1 To Rws, 1 To CoLs)
    For i = 1 To Rws
        If Not Dic.Exists(Data(i, 1)) Then
            k = k + 1:      Dic.Add Data(i, 1), k
            For j = 1 To CoLs
                KQ(k, j) = Data(i, j)
            Next j
        Else
            R = Dic.Item(Data(i, 1))
            If Data(i, 5) > KQ(R, CoLs) Then
                KQ(R, 4) = Data(i, 4):          KQ(R, CoLs) = Data(i, CoLs)
            End If
        End If
    Next i
    With Sheets("KetQua")
        .Range("A2:A100000").Resize(, CoLs).ClearContents
        If k Then Range("A2").Resize(k, CoLs).Value = Data
    End With
End Sub

Con chào Thầy, cảm ơn Thầy đã góp ý cho con ạ.
Dạ phải rồi Thầy ạ,sau khi gửi code lên con cũng có nghĩ thấy không ổn khi thay đổi dữ liệu gốc.

 

[Ba Tê]

Con chào Thầy, cảm ơn Thầy đã góp ý cho con ạ.
Dạ phải rồi Thầy ạ,sau khi gửi code lên con cũng có nghĩ thấy không ổn khi thay đổi dữ liệu gốc.

Chẳng hiểu sao code tôi sửa dựa theo bài của bạn ra kết quả "tào lao".
Đã gởi lại code ở bài trên.
-------------------------------
Đã thấy sai ở dòng này:
If k Then Range("A2").Resize(k, CoLs).Value = Data
Đúng phải là
If k Then Range("A2").Resize(k, CoLs).Value =KQ

 

[VetMini]

dữ liệu lớn như thế này nên dung pivot table nhé

Data Model và Power Pivot chứ.

Tôi có tật chạy theo thời trang. Thời trang mới bi giờ là Power BI. Ba cái VBA cũ xì rồi.
Cứ mấy cái yêu cầu Lọc, Xếp, Trích xuất hằng ngày ở GE này đem cho tụi Power Query, Power Pivot, Data Model chúng xơi tuốt.

 

[Hoàng Nhật Phương]

Chẳng hiểu sao code tôi sửa dựa theo bài của bạn ra kết quả "tào lao".
Đã gởi lại code ở bài trên.
-------------------------------
Đã thấy sai ở dòng này:
If k Then Range("A2").Resize(k, CoLs).Value = Data
Đúng phải là
If k Then Range("A2").Resize(k, CoLs).Value =KQ

Cảm ơn Thầy , qua cách làm của Thầy con học thêm được chiêu so sánh ngày trong mảng mà không cần sử dụng tính năng sắp xếp.
So sánh với kết quả của Thầy và của con thì con thấy kết của con bị sai do lấy thông tin của ngày cũ (yêu cầu là ngày mới), hiện con đã sửa lại bài 4:

Order2:=xlDescending

Để sắp xếp từ ngày mới đến ngàycũ.

 

[VetMini]

...Dim I As Long, J As Long, K As Long, R As Long, Rws As Long

Dòng của bạn là dòng thứ tự (chỉ số) chứ không phải là dòng đếm. Tức là nó số ít chứ không phải số nhiều. Đặt tên không cần 's'.
Để phân biệt nó là chỉ số mảng chứ không phải chỉ số dòng bảng tính, bạn nên thêm tiền/hậu tố 'a' (tôi chọn 'a' do mảng của bạn đặt tên có 'Arr')
Tức là aRw, hoặc rwA là đẹp.

 

[Hoàng Nhật Phương]

Dữ liệu "nguyên xi" của người ta, đem đi Sort, nhìn lại "lạ hoắc" người ta có chịu không?
Đã xài Dic thì cứ cho nó lung tung cũng được mà.

Theo góp ý của Thầy ,không động chạm đến dữ liệu ban đầu do vậy con thử dùng sort và bỏ Dic ạ:

Public Sub TimGiaCuaNgayMoiNHat()
    Dim Data(), Rng As Range, rKQ As Range, i As Long, j As Long, k As Long
    With ThisWorkbook.Worksheets("Sheet1")
        Set Rng = .Cells(1, "A").CurrentRegion
        i = Rng.Columns.Count + 2
        Rng.Offset(, i).Value = Rng.Value
        Set rKQ = .Cells(1, "A").Offset(, i)
        rKQ.CurrentRegion.Sort Key1:=rKQ, Order1:=xlAscending, Key2:=rKQ.Offset(, 4), Order2:=xlDescending, Orientation:=xlTopToBottom, Header:=xlYes
        Data = rKQ.CurrentRegion.Value2: k = 1
        For i = 2 To UBound(Data, 1)
            If Data(i, 1) <> Data(i - 1, 1) Then
                k = k + 1
                For j = 1 To UBound(Data, 2)
                    Data(k, j) = Data(i, j)
                Next j
            End If
        Next i
        rKQ.Offset(1).Resize(Rng.Rows.Count - 1, Rng.Columns.Count).ClearContents
        If k Then rKQ.Resize(k, UBound(Data, 2)).Value = Data
    End With
End Sub

------------
Bác @VetMini ơi, bài toán này mà dùng 'arraylist' có phù hợp không Bác.. nếu phù hợp Bác chỉ cho con dùng như thế nào ạ?

 

[ptm0412]

Theo góp ý của Thầy ,không động chạm đến dữ liệu ban đầu do vậy con thử dùng sort và bỏ Dic ạ:

Vẫn sort dữ liệu gốc kìa

 

[Hoàng Nhật Phương]

Vẫn sort dữ liệu gốc kìa

Ớ,cột A đến E thôi chú Mỹ nhé
Con có thấy vấn đề gì đâu ạ.

 

[ptm0412]

Ớ,cột A đến E thôi chú Mỹ nhé
Con có thấy vấn đề gì đâu ạ.

Vẫn là sort. Sao chép, Sort, rồi xử lý, rồi xoá, rồi điền kết quả. current rồi Offset resize loằng ngoằng. Cứ bám vào 1 thuật toán ban đầu nó khổ vậy á. Đập hết làm lại còn hay hơn

 

[Hoàng Nhật Phương]

Vẫn là sort. Sao chép, Sort, rồi xử lý, rồi xoá, rồi điền kết quả. current rồi Offset resize loằng ngoằng. Cứ bám vào 1 thuật toán ban đầu nó khổ vậy á. Đập hết làm lại còn hay hơn

Con cũng đang muốn đập đi xây cái "arraylist" , chú Mỹ xem thế nào giúp con ít vốn.

 

[ptm0412]

Con cũng đang muốn đập đi xây cái "arraylist" , chú Mỹ xem thế nào giúp con ít vốn.

Tôi còn chưa biết cái "arraylist" là kí rì

 

[Hoàng Nhật Phương]

Tôi còn chưa biết cái "arraylist" là kí rì

Vậy là con hơn chú Mỹ món này rồi, con đã biết tham chiếu đến thư viên của nó và khai báo

 

[Hamedanger]

Sửa lại code #3 , ko cần đụng đến dữ liệu nguồn

Sub GPE()
Const CoLs = 5
Dim iArr As Variant, endR As Long, oArr As Variant, Dic As Object, iDic As Variant
Dim I As Long, J As Long, K As Long, MS As String, idStr As String, R As Long
With Sheet1
endR = .Range("A1048576").End(3).Row
iArr = .Range("A2:E" & endR).Value
End With

Set Dic = CreateObject("Scripting.Dictionary")
For I = LBound(iArr, 1) To UBound(iArr, 1)
MS = CStr(iArr(I, 1))
If Not Dic.Exists(MS) Then
Dic.Add MS, I
Else
idStr = Dic.Item(MS)
If iArr(I, 4) > iArr(idStr, 4) Then
Dic.Remove MS
Dic.Add MS, I
End If
End If
Next

ReDim oArr(1 To Dic.Count, 1 To CoLs)
iDic = Dic.items

For I = LBound(iDic, 1) To UBound(iDic, 1)
R = iDic(I)
For J = 1 To CoLs
oArr(I + 1, J) = iArr(R, J)
Next
Next
With Sheet2
.Range("A2:E1048576").ClearContents
.Range("A2").Resize(UBound(oArr, 1), CoLs) = oArr
End With
End Sub

Bài đã được tự động gộp: 24/7/21

If K Then Range("A1").Resize(K, CoLs).Value = dArr

Cách của A Ba tê thì chỉ phải đi 1 vòng lặp qua dữ liệu gốc nên cho tốc độ nhanh hơn nhưng cái mảng dArr thực tế là thừa dòng so với kết quả thu được. Muốn ko khai thừa lại mất công đảo ngược mảng kết quả rồi redim preserve từng dòng 1 , đến cuối vẫn phải transpose . Tính ra thì vẫn phải đi mất 2 vòng lặp.
Có cách nào chỉ đi 1 vòng mà mảng kết quả có đúng số dòng cần lấy ko nhỉ?

 

[ptm0412]

Có cách nào chỉ đi 1 vòng mà mảng kết quả có đúng số dòng cần lấy ko nhỉ?

Không có cách nào. Ngoài ra khai báo dArr dư cũng có lý do: Phải giả định rằng số dòng kết quả nhiều đến mức gần bằng hoặc bằng dữ liệu gốc. Dữ liệu khác thì có thể ước lượng, có khi ít hơn nhiều, cũng có khi nhiều hơn cả gốc.
Dù gì thì cũng có giới hạn dư chứ không dư quá mức.

 

[ptm0412]

Vậy là con hơn chú Mỹ món này rồi, con đã biết tham chiếu đến thư viên của nó và khai báo

Biết rồi thì làm đi.