Cải thiện tốc độ của Dictionary và Vòng lặp

[hakhuongdhkt]

Em chào các bác,

Trước em có nhờ 1 bác trên diễn đàn viết dùm code thay thế cho hàm Vlookup, chạy rất tốt.
Nhưng gần đây do yêu cầu thay đổi, cần phải sửa lại code 1 chút như trong file.

Mục đích: e nhập Sub-Category và Quantity vào sheet "Tim kiem", sau đó chạy code để lấy các thông tin tương ứng (đầu tiên tìm được) với các Sub-Category trong các sheet 2013, 2014, 2015, 2016 mà thỏa mãn điều kiện Quantity lớn hơn Quantity đã nhập tại sheet "Tim kiem".

Tuy nhiên tốc độ chạy rất chậm (do dữ liệu tại các sheet 2013, 2014, 2015, 2016 rất lớn, mỗi sheet ~ 800k dòng).
Các bác xem có thể cải thiện tốc độ bằng cách nào không ạ?
Mong các bác giúp đỡ!

Sub Vlookup()
Application.ScreenUpdating = False
Dim arr, data, inputdata, varKey, temvl, dic As Object
Dim i As Long, j As Long, sh As Worksheet, lr As Long
Set dic = CreateObject("scripting.dictionary")
Set shtk = ThisWorkbook.Sheets(1)

lr = shtk.Range("A" & Rows.Count).End(xlUp).Row
shtk.Range("C2:H" & lr).ClearContents
inputdata = shtk.Range("A2:J" & lr).Value
For i = 1 To UBound(inputdata)
    If Not dic.exists(inputdata(i, 1)) Then
        dic.Add inputdata(i, 1), Array(inputdata(i, 2), inputdata(i, 3), inputdata(i, 4), inputdata(i, 5), inputdata(i, 6))
    Else
        temparr = dic(inputdata(i, 1))
        temparr(0) = temparr(0) + inputdata(i, 2)
        dic(inputdata(i, 1)) = temparr
    End If
Next i
For Each varKey In dic.Keys()
    flg = False
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "Tim kiem" And sh.Name <> "Tru ton" Then
           lr = sh.Range("A" & Rows.Count).End(xlUp).Row
           data = sh.Range("A2:F" & lr).Value
           For i = 1 To UBound(data)
               If varKey = data(i, 1) Then
                    If dic.Item(varKey)(0) <= data(i, 6) Then
                    dic(data(i, 1)) = Array(data(i, 6), data(i, 2), data(i, 3), data(i, 4), data(i, 5))
                    flg = True
                    Exit For
                    End If
               End If
            Next
        End If
        If flg = True Then Exit For
    Next
Next
With shtk
     lr = .Range("A" & Rows.Count).End(xlUp).Row
     If lr = 1 Then Exit Sub
     .Range("C2:H" & lr).ClearContents
     arr = .Range("A2:H" & lr).Value
     For i = 1 To UBound(arr)
         If dic.exists(arr(i, 1)) Then
            arr(i, 3) = dic.Item(arr(i, 1))(1)
            arr(i, 4) = dic.Item(arr(i, 1))(2)
            arr(i, 5) = dic.Item(arr(i, 1))(3)
            arr(i, 6) = dic.Item(arr(i, 1))(4)
            arr(i, 7) = dic.Item(arr(i, 1))(0)
            arr(i, 8) = arr(i, 7) - arr(i, 2)
        End If
    Next i
    .Range("A2:H" & lr).Value = arr
End With

Application.ScreenUpdating = True
End Sub

 

[Quang_Hải]

Em không có ý xem trọng cái này, đánh giá thấp cái kia. Vẫn biết mỗi cái có lợi thế riêng, nhưng do kiến thức em hạn hẹp khó có thể lĩnh hội ngay cái mới được nên mong các bác giúp đỡ ạ.

Tôi ủng hộ xài những gì mà mình am hiểu về nó. Thà đi xe đạp còn hơn đi xe hơi rồi đạp nhầm chân ga, thay vì đạp chân thắng. Mục đích cuối cùng cũng là kiếm tiền để mưu sinh.

 

[SA_DQ]

Trước em có nhờ 1 bác trên diễn đàn viết dùm code thay thế cho hàm Vlookup, chạy rất tốt.
Nhưng gần đây do yêu cầu thay đổi, cần phải sửa lại code 1 chút như trong file.
. . . .
Mong các bác giúp đỡ!
. . . .

Chủ bài đăng đã nghĩ tới chuyện kiện toàn thiết kế file chưa vậy? Ví dụ ở cột này:

Order ID

CA-2012-124891

IN-2012-86369

CA-2012-116638

ID-2012-28402

MX-2012-130015

PL-2012-7820

IN-2012-44810

ES-2012-5870268

Như mình thì 2 kí tự nối có thể dẹp đi; & 4 kí số (đều là) 2012 nên biến thành 1 ký hiệu nào đó như '-', 'B' hay '2', . . . .
Vì mình chưa biết các kí số cuối của mã mang ý nghĩa gì, nên chưa thể phát biểu, nhưng chúng nên có số kí tự là như nhau

 

[VetMini]

Tôi ủng hộ xài những gì mà mình am hiểu về nó. Thà đi xe đạp còn hơn đi xe hơi rồi đạp nhầm chân ga, thay vì đạp chân thắng. Mục đích cuối cùng cũng là kiếm tiền để mưu sinh.

Ví von không đúng. Ở đây, đâu phải là xe đạp với xe hơi. Cả hai đều là xe tải, ví dụ xe hàng đa dụng với đầu kéo công-ten-nơ may ra gần hơn.
Vảb lại xe gì cũng chẳng phải do mình lái. VBA cũng là nhờ viết giùm chứ có phải tự đâu?

 

[hakhuongdhkt]

Tôi viết bằng code M trong Power query , tài liệu cơ bản thì kéo lên đầu trang có của thầy Ptm, bạn để data thật của bạn xem chạy nhanh hơn không, chép lại data 4 sheet 2013,2014,2015,2016 rồi bấm refresh bên sheet tìm kiếm
View attachment 248229

Không biết sao em thử copy dữ liệu thật vào thì load mãi k xong (not responding), chắc tại e không biết dùng

Bài đã được tự động gộp: 29/10/20

Thử code đồ cổ xem sao

Sub XYZ()
  Application.ScreenUpdating = False
  Dim sArr(), aData(), Res(), iKey$, S, dic As Object
  Dim eRow&, sRow&, i&, j&, sh As Worksheet
   
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("Tim kiem")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    aData = .Range("A2:B" & eRow).Value
  End With
  sRow = UBound(aData)
  For i = 1 To sRow
    iKey = aData(i, 1)
    dic.Item(iKey) = dic.Item(iKey) + aData(i, 2)
  Next i
  For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> "Tim kiem" And sh.Name <> "Tru ton" Then
      sArr = sh.Range("A2:F" & sh.Range("A" & Rows.Count).End(xlUp).Row).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        iKey = sArr(i, 1)
        If dic.exists(iKey) Then
          If dic.exists(iKey & "#") = False Then
            If dic.Item(iKey) <= sArr(i, 6) Then
              dic(iKey & "#") = Array(sArr(i, 2), sArr(i, 3), sArr(i, 4), sArr(i, 5), sArr(i, 6))
              dic(iKey) = sArr(i, 6)
            End If
          End If
        End If
      Next i
    End If
  Next
  sRow = UBound(aData)
  ReDim Res(1 To sRow, 0 To 5)
  For i = 1 To sRow
    iKey = aData(i, 1)
    Res(i, 4) = dic.Item(iKey)
    If dic.exists(iKey & "#") Then
      S = dic.Item(iKey & "#")
      For j = 0 To 3
        Res(i, j) = S(j)
      Next j
    End If
    Res(i, 5) = Res(i, 4) - aData(i, 2)
  Next i
  With Sheets("Tim kiem")
    .Range("C2").Resize(sRow, 6).Value = Res
  End With
  Application.ScreenUpdating = True
End Sub

Code chạy ngon bác ạ. Cảm ơn bác nhiều
Sau một ngày ngẫm nghĩ e phát hiện ra e code chạy chậm là do e đang để với mỗi key trong dic, lại phải dò lại toàn bộ trong 4 sheet. K chậm mới lạ

Bài đã được tự động gộp: 29/10/20

Chủ bài đăng đã nghĩ tới chuyện kiện toàn thiết kế file chưa vậy? Ví dụ ở cột này:

Order ID

CA-2012-124891

IN-2012-86369

CA-2012-116638

ID-2012-28402

MX-2012-130015

PL-2012-7820

IN-2012-44810

ES-2012-5870268

Như mình thì 2 kí tự nối có thể dẹp đi; & 4 kí số (đều là) 2012 nên biến thành 1 ký hiệu nào đó như '-', 'B' hay '2', . . . .
Vì mình chưa biết các kí số cuối của mã mang ý nghĩa gì, nên chưa thể phát biểu, nhưng chúng nên có số kí tự là như nhau

Dữ liệu này e lấy trên internet để làm mẫu.
Cảm ơn bác đã góp ý ạ. E xin tiếp thu và ứng dụng ạ

Bài đã được tự động gộp: 29/10/20

Tôi ủng hộ xài những gì mà mình am hiểu về nó. Thà đi xe đạp còn hơn đi xe hơi rồi đạp nhầm chân ga, thay vì đạp chân thắng. Mục đích cuối cùng cũng là kiếm tiền để mưu sinh.

Cảm ơn bác đã cho e động lực ạ