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

Blue Softs Liên hệ QC

VetMini

Chuyên gia GPE
Tham gia
21/12/12
Bài viết
12,353
Được thích
15,918
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.
Có cách khá hữu hiệu nhưng hơi mất công chút. Thường thì không bỏ công làm.
- Lâp một mảng cỡ tương đối
- Cứ mõi lần thêm dòng thì xét nếu khong đủ thì nới thêm. Có thể dùng On Error để bắt lỗi này.
- Nới thêm: copy qua mọt mảng mới, redim mảng cũ, copy trở lại.
- Lúc copy trở lại, dùng kỹ thuật memcopy của C. Windows có hàm API để làm chuyện này. Và vấn đề này đã được đề cập vài lần ởi GPE.

Cách khác, chỉ hữu hiệu cho dân chuyên tách code dài ra thành hàm con. Nói cách khác, là dân quen viết hàm con.
- Lập mảng cỡ tương đối. Mảng tĩnh cho nhanh
- Cứ mỗi lần thêm dòng thì xét nếu khong đủ thì chuyển qua mảng mới. Có thể dùng On Error để bắt lỗi này.
- Cách thức chuyển mảng:
- - Đặt một mảng Variant, khoảng 1000 phần tử
- - Copy mảng chính vào phần tử kế tiếp
- - Bây giờ có thể xài lại mảng chính (erase nếu cần, nhưng thường thì ta viết chồng lên nên không cần)
- Cuối cùng sẽ được một mảng chứa những mảng kết quả.
 

Hamedanger

Thành viên chính thức
Tham gia
2/12/14
Bài viết
60
Được thích
23
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 @!>><
Mình test thử arraylist ko hiểu là dùng không đúng cách hay như thế nào? Mà so với code dùng Dic của a Bate thấy nó chậm bà cố luôn .
(Sửa lại chính code của a ba tê thay Dic bằng Arrlist)

PHP:
Sub GPE_ArrList()

Const CoLs2 As Long = 5

Dim aLst As Object, sArr(), dArr(), Txt As String, T

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

T = Timer

Set aLst = CreateObject("System.Collections.ArrayList")

    sArr = Sheet1.Range("A1", Sheet1.Range("A1").End(xlDown)).Resize(, CoLs2).Value

    R = UBound(sArr)

ReDim dArr(1 To R, 1 To CoLs2)

    For I = 1 To R

        Txt = sArr(I, 1)

        If Not aLst.Contains(Txt) Then

            K = K + 1

            aLst.Add Txt

            For J = 1 To CoLs2

                dArr(K, J) = sArr(I, J)

            Next J

        Else

            Rws = aLst.IndexOf(Txt, 0)

            If sArr(I, CoLs2) > dArr(Rws + 1, CoLs2) Then

                dArr(Rws + 1, 4) = sArr(I, 4)

                dArr(Rws + 1, CoLs2) = sArr(I, CoLs2)

            End If

        End If

    Next I

    With Sheets("KetQua")

        .Range("G1:G100000").Resize(, CoLs2).ClearContents

        If K Then Range("G1").Resize(K, CoLs2).Value = dArr

    End With

Set aLst = Nothing

[F10].Value = Timer - T

End Sub
 

File đính kèm

  • GPE.xlsm
    4.1 MB · Đọc: 5
Chỉnh sửa lần cuối bởi điều hành viên:

Ba Tê

Cạo Rồi Khỏi Gội
Tham gia
5/5/09
Bài viết
12,115
Được thích
17,494
Sửa lại code #3 , ko cần đụng đến dữ liệu nguồn

Bài đã được tự động gộp:


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ỉ?
Bạn "lo lắng" số dòng mảng kết quả có thể nhỏ hơn số dòng khai báo mảng kết quả, làm cho nó có gì đó hơi "lăng tăng"?
Với bài này, có thể mảng kết quả có số dòng bằng với mảng nguồn, khi mảng nguồn cột Mã hàng không trùng.
Muốn hết "lo Bò trắng răng" có thể thử không cần mảng dArr() kiểu này xem:
PHP:
Option Explicit

Sub GPE()
Application.ScreenUpdating = False
Const CoLs As Long = 5
Dim Dic As Object, sArr(), 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
With Sheet1
    sArr = Range("A1", .Range("A1").End(xlDown)).Resize(, CoLs).Value
    Rws = UBound(sArr)
    For I = 1 To Rws
        Txt = sArr(I, 1)
        If Not Dic.Exists(Txt) Then
            K = K + 1
            Dic.Item(Txt) = K
            For J = 1 To CoLs
                sArr(K, J) = sArr(I, J)
            Next J
        Else
            R = Dic.Item(Txt)
            If sArr(I, CoLs) > sArr(R, CoLs) Then
                sArr(R, 4) = sArr(I, 4)
                sArr(R, CoLs) = sArr(I, CoLs)
            End If
        End If
    Next I
        .Range("G1").Resize(Rws, CoLs).ClearContents
        .Range("G1").Resize(K, CoLs) = sArr
End With
Set Dic = Nothing
End Sub
 

File đính kèm

  • GiaMua.xlsb
    890.4 KB · Đọc: 4
Top Bottom