Cập nhật các cột còn lại theo mã với dữ liệu lớn (1 người xem)

[Hanguyenktxd]

Gửi các anh chị trên diễn đàn
Do nhu cầu cần cập nhật một danh mục với số liệu lớn các dòng, mình có tham khảo trên diễn đàn và tìm được một code:


Sub UPDATE()
Application.ScreenUpdating = False
Dim Code(), T1()
Dim i&, Rng1 As Range
With Sheets("TRA")
Code = .Range(.[A2], .[D65000].End(1)).Value
End With
ReDim T1(1 To UBound(Code), 1 To 4)
For i = 1 To UBound(Code)
Set Rng1 = Sheets("DM").[A:A].Find(Code(i, 1), , , 1)
If Not Rng1 Is Nothing Then
T1(i, 1) = Rng1.Offset(, 1)
T1(i, 2) = Rng1.Offset(, 2)
T1(i, 3) = Rng1.Offset(, 3)
T1(i, 4) = Rng1.Offset(, 4)
End If
Next
With Sheets("TRA")
.[B2].Resize(i - 1, 4) = T1


End With
Set Rng1 = Nothing
Application.ScreenUpdating = True
End Sub


mục đích của mình là truy tìm các cột còn lại của danh mục theo mã (giống hàm vlookup) của Sheet "TRA" theo Sheet "DM" nhưng kết quả chạy rất chậm, các anh chị trên diễn đàn vui lòng giúp mình một đoạn code lấy dữ liệu cho kết quả nhanh hơn code trên được không ạ
Cám ơn các anh chị rất nhiều


http://www.mediafire.com/view/u7irpu1fbhyh5yp/Update.xlsm

 

[doveandrose]

rồi ca này hấp dẫn nè . up cho lên cao chờ cao thủ vào trổ tài

 

[Ba Tê]

Gửi các anh chị trên diễn đàn
Do nhu cầu cần cập nhật một danh mục với số liệu lớn các dòng, mình có tham khảo trên diễn đàn và tìm được một code:
--------------------------------

mục đích của mình là truy tìm các cột còn lại của danh mục theo mã (giống hàm vlookup) của Sheet "TRA" theo Sheet "DM" nhưng kết quả chạy rất chậm, các anh chị trên diễn đàn vui lòng giúp mình một đoạn code lấy dữ liệu cho kết quả nhanh hơn code trên được không ạ
Cám ơn các anh chị rất nhiều


http://www.mediafire.com/view/u7irpu1fbhyh5yp/Update.xlsm

Máy bạn chạy được code trên đã là máy "khủng" rồi, máy tôi thì "điếc" luôn.
Thử code này xem sao:

Sub UPDATE_2()
Dim Dic As Object, sArr(), dArr(), I As Long, J As Long, Rws As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("TRA")
    sArr = .Range(.[A2], .[A2].End(xlDown)).Value2
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1)
    If Not Dic.Exists(Tem) Then Dic.Add Tem, I
Next I
With Sheets("DM")
    sArr = .Range(.[A2], .[A2].End(xlDown)).Resize(, 4).Value2
End With
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1)
    If Dic.Exists(Tem) Then
        Rws = Dic.Item(Tem)
        For J = 2 To 4
            dArr(Rws, J - 1) = sArr(I, J)
        Next J
    End If
Next I
Sheets("TRA").[B2].Resize(UBound(dArr, 1), 3) = dArr
Set Dic = Nothing
End Sub

 

[Hanguyenktxd]

Máy bạn chạy được code trên đã là máy "khủng" rồi, máy tôi thì "điếc" luôn.
Thử code này xem sao:

Sub UPDATE_2()
Dim Dic As Object, sArr(), dArr(), I As Long, J As Long, Rws As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("TRA")
    sArr = .Range(.[A2], .[A2].End(xlDown)).Value2
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1)
    If Not Dic.Exists(Tem) Then Dic.Add Tem, I
Next I
With Sheets("DM")
    sArr = .Range(.[A2], .[A2].End(xlDown)).Resize(, 4).Value2
End With
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1)
    If Dic.Exists(Tem) Then
        Rws = Dic.Item(Tem)
        For J = 2 To 4
            dArr(Rws, J - 1) = sArr(I, J)
        Next J
    End If
Next I
Sheets("TRA").[B2].Resize(UBound(dArr, 1), 3) = dArr
Set Dic = Nothing
End Sub

Gửi bạn Ba Tê cùng các bạn trên diễn đàn
code này chạy rất nhanh nhưng không thể cập nhật 2 mã trùng nhau (trong sheet "TRA" nếu có 2 mã hoặc nhiều hơn trùng nhau thì code chỉ cập nhật mã thứ nhất còn mã thứ 2,3,... giống thứ nhất thì bỏ trống), bạn Ba Tê có thể sửa lại giùm mình lấy luôn những mã trùng nhau không, vì thỉnh thoảng mình được gửi cả những file có mã trùng, xin lỗi bạn về sự phát sinh này.
Cám ơn bạn đã giúp đỡ rất nhiều

 

[Ba Tê]

Gửi bạn Ba Tê cùng các bạn trên diễn đàn
code này chạy rất nhanh nhưng không thể cập nhật 2 mã trùng nhau (trong sheet "TRA" nếu có 2 mã hoặc nhiều hơn trùng nhau thì code chỉ cập nhật mã thứ nhất còn mã thứ 2,3,... giống thứ nhất thì bỏ trống), bạn Ba Tê có thể sửa lại giùm mình lấy luôn những mã trùng nhau không, vì thỉnh thoảng mình được gửi cả những file có mã trùng, xin lỗi bạn về sự phát sinh này.
Cám ơn bạn đã giúp đỡ rất nhiều

Thay cái cũ bằng cái này thử xem:

Sub UPDATE_2()
Dim Dic As Object, sArr(), tArr(), dArr(), I As Long, J As Long, Rws As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DM")
    sArr = .Range(.[A2], .[A2].End(xlDown)).Resize(, 4).Value2
End With
ReDim tArr(1 To UBound(sArr, 1), 1 To 3)
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1)
    Dic.Item(Tem) = I
        For J = 2 To 4
            tArr(I, J - 1) = sArr(I, J)
        Next J
Next I
With Sheets("TRA")
    sArr = .Range(.[A2], .[A2].End(xlDown)).Value2
    ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
    For I = 1 To UBound(sArr, 1)
        Tem = sArr(I, 1)
        If Dic.Exists(Tem) Then
            Rws = Dic.Item(Tem)
            For J = 1 To 3
                dArr(I, J) = tArr(Rws, J)
            Next J
        End If
    Next I
    .[B2].Resize(UBound(sArr, 1), 3) = dArr
End With
Set Dic = Nothing
End Sub