Tăng tốc cho phương thức tìm kiếm FIND (1 người xem)

Cá ngừ F1 · 10/6/14

E có 1 file Excel gồm 4 sheet: Data, Nguon, CL, Note
Sheet Data có 2 trường chính (Lookup Value) là: Ma_Nguon và Ma_CL
E có sử dụng phương thức Find:
- Tìm kiếm thông tin SO và Ten_Nguon từ sheet NGUON
- Tìm kiếm thông tin Ten_CL, ED, LT, CL, TO, CB, AB từ sheet CL
- Dữ liệu sheet Nguon khá lớn: hơn 75 nghìn dòng

Mã:

Sub TimKiem()
    Dim SoThe(), LookCif()
    Dim DesArr1(), DesArr2(), DesArr3()
    Dim i As Long
    Dim String1 As Range, String2 As Range, String3 As Range
    With Sheet2
       SoThe = .Range(.[F6], .[F1048576].End(3)).Value
       LookCif = .Range(.[C6], .[C1048576].End(3)).Value
    End With
    ReDim DesArr1(1 To UBound(SoThe), 1 To 1)
    ReDim DesArr2(1 To UBound(SoThe), 1 To 7)
    ReDim DesArr3(1 To UBound(LookCif), 1 To 2)
    For i = 1 To UBound(SoThe)
       Set String1 = Sheet6.[A:A].Find(SoThe(i, 1), , , 1)
       Set String3 = Sheet3.[B:B].Find(LookCif(i, 1), , , 1)
       If Not String1 Is Nothing Then
            Set String2 = Sheet4.[F:F].Find(String1.Offset(, 3), , , 1)
                If Not String2 Is Nothing Then
                DesArr1(i, 1) = String2.Offset(, 1)
                End If
            DesArr2(i, 1) = String1.Offset(, 1)
            DesArr2(i, 2) = String1.Offset(, 5)
            DesArr2(i, 3) = String1.Offset(, 6)
            DesArr2(i, 4) = String1.Offset(, 7)
            DesArr2(i, 5) = String1.Offset(, 8)
            DesArr2(i, 6) = String1.Offset(, 9)
            DesArr2(i, 7) = String1.Offset(, 10)
       End If
       If Not String3 Is Nothing Then
            DesArr3(i, 1) = String3.Offset(, 10)
            DesArr3(i, 2) = String3.Offset(, 7)
       End If
    Next
    With Sheet2
        .[N6].Resize(i - 1) = DesArr1
        .[O6].Resize(i - 1, 7) = DesArr2
        .[D6].Resize(i - 1, 2) = DesArr3
    End With
    Set String1 = Nothing: Set String2 = Nothing: Set String3 = Nothing
End Sub

Code chạy ra kết quả, tuy nhiên thì quá chậm so với yêu cầu
Có cách nào để cải thiện tăng tốc ko ạh
E xin cảm ơn...
File đính kèm: http://www.mediafire.com/view/b0djm7d101185jy/TANG_TOC_CHO_FIND.xlsm

Ba Tê · 10/6/14

Cá ngừ F1 đã viết:
E có 1 file Excel gồm 4 sheet: Data, Nguon, CL, Note
Sheet Data có 2 trường chính (Lookup Value) là: Ma_Nguon và Ma_CL
E có sử dụng phương thức Find:
- Tìm kiếm thông tin SO và Ten_Nguon từ sheet NGUON
- Tìm kiếm thông tin Ten_CL, ED, LT, CL, TO, CB, AB từ sheet CL
- Dữ liệu sheet Nguon khá lớn: hơn 75 nghìn dòng

Code chạy ra kết quả, tuy nhiên thì quá chậm so với yêu cầu
Có cách nào để cải thiện tăng tốc ko ạh
E xin cảm ơn...
File đính kèm: http://www.mediafire.com/view/b0djm7d101185jy/TANG_TOC_CHO_FIND.xlsm

Thử thằng này xem có nhanh hơn được chút nào không?
[GPECODE=vb]Public Sub GPE_X()
Dim Dic1 As Object, Dic2 As Object, sArr(), dArr(), dArr2(), STT(), sArr2(), t As Variant
Dim I As Long, J As Long, K As Long, Tem As Variant, N As Long, Tem2 As Variant
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
t = Timer
With Sheets("Data")
sArr = .Range(.[C6], .[C1048576].End(xlUp)).Value2
sArr2 = .Range(.[C6], .[C1048576].End(xlUp)).Offset(, 3).Value2
End With
N = UBound(sArr, 1)
ReDim dArr(1 To N, 1 To 2)
ReDim dArr2(1 To N, 1 To 7)
ReDim STT(1 To N, 1 To 1)
For I = 1 To N
K = K + 1: Tem = sArr(I, 1): Tem2 = sArr2(I, 1)
If Not Dic1.Exists(Tem) Then Dic1.Add Tem, K
If Not Dic2.Exists(Tem2) Then Dic2.Add Tem2, K
STT(K, 1) = K
Next I
With Sheets("NGUON")
sArr = .Range(.[B2], .[B1048576].End(xlUp)).Resize(, 11).Value2
End With
N = UBound(sArr, 1)
For I = 1 To N
Tem = sArr(I, 1)
If Dic1.Exists(Tem) Then
dArr(Dic1.Item(Tem), 1) = sArr(I, 11)
dArr(Dic1.Item(Tem), 2) = sArr(I, 8)
End If
Next I
With Sheets("CL")
sArr = .Range(.[A2], .[A1048576].End(xlUp)).Resize(, 12).Value
End With
N = UBound(sArr, 1)
For I = 1 To N
Tem = sArr(I, 1)
If Dic2.Exists(Tem) Then
dArr2(Dic2.Item(Tem), 1) = sArr(I, 2)
dArr2(Dic2.Item(Tem), 7) = sArr(I, 12)
For J = 2 To 6
dArr2(Dic2.Item(Tem), J) = sArr(I, J + 4)
Next J
End If
Next I
With Sheets("Data")
.[A6].Resize(K) = STT
.[D6:E6].Resize(K) = dArr
.[O6:U6].Resize(K) = dArr2
End With
Set Dic1 = Nothing
Set Dic2 = Nothing
MsgBox Timer - t
End Sub[/GPECODE]

Let'GâuGâu · 10/6/14

Cá ngừ F1 đã viết:
E có 1 file Excel gồm 4 sheet: Data, Nguon, CL, Note
Sheet Data có 2 trường chính (Lookup Value) là: Ma_Nguon và Ma_CL
E có sử dụng phương thức Find:
- Tìm kiếm thông tin SO và Ten_Nguon từ sheet NGUON
- Tìm kiếm thông tin Ten_CL, ED, LT, CL, TO, CB, AB từ sheet CL
- Dữ liệu sheet Nguon khá lớn: hơn 75 nghìn dòng

chắc không phải tại find dâu mà do cái vòng lặp
đưa hết vào mảng thì nó sẻ khá hơn
tôi làm thử cái DesArr2 thử

Mã:

Sub TimKiem()
    Dim SoThe(), LookCif(), CL() As Variant, dic As Object
    Dim DesArr1(), DesArr2(), DesArr3()
    Dim i As Long
    Dim String1 As Range, String2 As Range, String3 As Range
    With Sheet2
       SoThe = .Range(.[F6], .[F10000].End(3)).Value
       LookCif = .Range(.[C6], .[C10000].End(3)).Value
    End With
    ReDim DesArr1(1 To UBound(SoThe), 1 To 1)
    ReDim DesArr2(1 To UBound(SoThe), 1 To 7)
    ReDim DesArr3(1 To UBound(LookCif), 1 To 2)
    
    Set dic = CreateObject("Scripting.Dictionary")

    For i = 1 To UBound(SoThe)
             If Not dic.Exists(SoThe(i, 1)) Then dic.Add SoThe(i, 1), ""
    Next
          
          With Sheet6
                CL = .Range(.[a2], .[A10000].End(3)).Resize(, 10).Value
            End With
        For i = 1 To UBound(CL)
             If dic.Exists(CL(i, 1)) Then
                k = k + 1
                DesArr2(k, 1) = CL(i, 1)
                DesArr2(k, 2) = CL(i, 5)
                DesArr2(k, 3) = CL(i, 6)
                DesArr2(k, 4) = CL(i, 7)
                DesArr2(k, 5) = CL(i, 8)
                DesArr2(k, 6) = CL(i, 9)
                DesArr2(k, 7) = CL(i, 10)
            End If
        Next
      
    
    With Sheet2
       
        .[O6].Resize(k, 7) = DesArr2
        
    End With
    Set dic = Nothing
    Erase SoThe, CL
    
End Sub

Cá ngừ F1 · 10/6/14

Let'GâuGâu đã viết:
chắc không phải tại find dâu mà do cái vòng lặp
đưa hết vào mảng thì nó sẻ khá hơn
tôi làm thử cái DesArr2 thử

Đưa hết vào mảng có phải mấu chốt ở chỗ Set dic = CreateObject("Scripting.Dictionary")
Cài này quả thật là tôi chưa biết chút j?
Nhanh hơn thật.. rất mong mng chỉ bảo thêm...

Code của thầy Bate cũng rất nhanh ạh... e cảm ơn nhiều..

Cá ngừ F1 · 10/6/14

Let'GâuGâu đã viết:

chắc không phải tại find dâu mà do cái vòng lặp
đưa hết vào mảng thì nó sẻ khá hơn
tôi làm thử cái DesArr2 thử

Mã:

Sub TimKiem()
    Dim SoThe(), LookCif(), CL() As Variant, dic As Object
    Dim DesArr1(), DesArr2(), DesArr3()
    Dim i As Long
    Dim String1 As Range, String2 As Range, String3 As Range
    With Sheet2
       SoThe = .Range(.[F6], .[F10000].End(3)).Value
       LookCif = .Range(.[C6], .[C10000].End(3)).Value
    End With
    ReDim DesArr1(1 To UBound(SoThe), 1 To 1)
    ReDim DesArr2(1 To UBound(SoThe), 1 To 7)
    ReDim DesArr3(1 To UBound(LookCif), 1 To 2)
    
    Set dic = CreateObject("Scripting.Dictionary")

    [COLOR=#ff0000][B]For i = 1 To UBound(SoThe)
             If Not dic.Exists(SoThe(i, 1)) Then dic.Add SoThe(i, 1), ""[/B][/COLOR]
    Next
          
          With Sheet6
                CL = .Range(.[a2], .[A10000].End(3)).Resize(, 10).Value
            End With
        For i = 1 To UBound(CL)
             If dic.Exists(CL(i, 1)) Then
                k = k + 1
                DesArr2(k, 1) = CL(i, 1)
                DesArr2(k, 2) = CL(i, 5)
                DesArr2(k, 3) = CL(i, 6)
                DesArr2(k, 4) = CL(i, 7)
                DesArr2(k, 5) = CL(i, 8)
                DesArr2(k, 6) = CL(i, 9)
                DesArr2(k, 7) = CL(i, 10)
            End If
        Next
      
    
    With Sheet2
       
        .[O6].Resize(k, 7) = DesArr2
        
    End With
    Set dic = Nothing
    Erase SoThe, CL
    
End Sub

A Let'GâuGâu có thể giải thích thêm cái đoạn đỏ đỏ được ko ạh...

chuot0106 · 10/6/14

Cá ngừ F1 đã viết:
A Let'GâuGâu có thể giải thích thêm cái đoạn đỏ đỏ được ko ạh...

Dòng lệnh For i=1 to Ubound(sothe) chắc bạn đã biết đúng không?
còn dòng lệnh: If Not dic.Exists(SoThe(i, 1)) Then dic.Add SoThe(i, 1), "" có nghĩa là kiểm tra xem phần tử SoThe(i, 1) đã có chưa, nếu chưa có thì lấy phần tử đó làm Key (dic.Add SoThe(i, 1), "").

leonguyenz · 10/6/14

Cá ngừ F1 đã viết:
Đưa hết vào mảng có phải mấu chốt ở chỗ Set dic = CreateObject("Scripting.Dictionary")
Cài này quả thật là tôi chưa biết chút j?
Nhanh hơn thật.. rất mong mng chỉ bảo thêm...

Thế mới nói, kiến thức VBA mênh mông lắm, thụ giáo mỗi Find thôi thì chưa xuống núi được đâu.
Bí kíp của bạn chuot0106 đây, F1 vào đó luyện công: Học Dictionary qua các ví dụ đơn giản!

Cá ngừ F1 · 10/6/14

leonguyenz đã viết:
Thế mới nói, kiến thức VBA mênh mông lắm, thụ giáo mỗi Find thôi thì chưa xuống núi được đâu.
Bí kíp của bạn chuot0106 đây, F1 vào đó luyện công: Học Dictionary qua các ví dụ đơn giản!

Tạm thời vẫn trú ngụ ở đảo đào hoa thôi... chưa lên nổi núi để xuống a Leo ạh...

Tăng tốc cho phương thức tìm kiếm FIND (1 người xem)

Người dùng đang xem chủ đề này

Cá ngừ F1

( ͡° ͜ʖ ͡°)

Ba Tê

Cạo Rồi Khỏi Gội

Let'GâuGâu

Thành viên mới

Cá ngừ F1

( ͡° ͜ʖ ͡°)

Cá ngừ F1

( ͡° ͜ʖ ͡°)

chuot0106

Thành viên gắn bó

leonguyenz

Thành viên gạo cội

Cá ngừ F1

( ͡° ͜ʖ ͡°)

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.