Dò tìm dữ liệu & lấy kết quả theo điều kiện bằng VBA (3 người xem)

[sonminhtran]

Vui lòng giúp mình có 1 file cần dò tìm dữ liệu:

Ở Sheet 'Shopee' từ cột J2 tới P2 cần dò tìm dữ liệu ở Sheet 'Data' với điều kiện:

* Nếu Sheet 'Shopee' ở ô A2, A3 giống mã đơn (250318UY8KWH73) thì dò tìm ở Sheet 'Data' cột A tham chiếu cột D lấy dữ liệu 2 dòng khác nhau cùng mã đơn cột A2, A3 và các cột khác như giải thích trong file đính kèm

Xin cảm ơn

 

[HieuCD]

Vui lòng giúp mình có 1 file cần dò tìm dữ liệu:

Ở Sheet 'Shopee' từ cột J2 tới P2 cần dò tìm dữ liệu ở Sheet 'Data' với điều kiện:

* Nếu Sheet 'Shopee' ở ô A2, A3 giống mã đơn (250318UY8KWH73) thì dò tìm ở Sheet 'Data' cột A tham chiếu cột D lấy dữ liệu 2 dòng khác nhau cùng mã đơn cột A2, A3 và các cột khác như giải thích trong file đính kèm

Xin cảm ơn

Kiểm tra lại

Sub xyz()
  Dim arr(), aMa(), aCol, a, res$(), res2(), dic As Object, key$
  Dim sR&, srMa&, i&, r&, j&
 
  With Sheets("Data")
    arr = .Range("A2", .Range("P" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("Shopee")
    aMa = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
  End With
 
  sR = UBound(arr):     srMa = UBound(aMa)
  aCol = Array(0, 1, 3, 4, 10, 11, 14, 16)
  ReDim res(1 To srMa, 1 To 7) 'Ket qua dang Text
  ReDim res2(1 To srMa, 1 To 1) 'Ket qua dang Number
 
  Set dic = CreateObject("Scripting.Dictionary")
  For i = 1 To srMa
    If dic.exists(aMa(i, 1)) = False Then
      dic(aMa(i, 1)) = Array(1, i)
    Else
      a = dic(aMa(i, 1))
      ReDim Preserve a(0 To UBound(a) + 1)
      a(UBound(a)) = i
      dic(aMa(i, 1)) = a
    End If
  Next i
 
  For i = 1 To sR
    If dic.exists(arr(i, 1)) Then
      a = dic(arr(i, 1))
      If a(0) <= UBound(a)  Then
        r = a(a(0))
        a(0) = a(0) + 1
        dic(arr(i, 1)) = a
        For j = 1 To 7
          res(r, j) = arr(i, aCol(j))
        Next j
        res2(r, 1) = arr(i, 14)
      End If
    End If
  Next
  Sheets("Shopee").Range("J2").Resize(srMa, 7).Value = res
  Sheets("Shopee").Range("O2").Resize(srMa, 1).Value = res2
End Sub

Nếu dữ liệu 2 sheet đã xếp thứ tự theo cột A thì không cần dùng Dic và tốc độ nhanh hơn nhiều.

 

[sonminhtran]

Kiểm tra lại

Sub xyz()
  Dim arr(), aMa(), aCol, a, res$(), res2(), dic As Object, key$
  Dim sR&, srMa&, i&, r&, j&
 
  With Sheets("Data")
    arr = .Range("A2", .Range("P" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("Shopee")
    aMa = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
  End With
 
  sR = UBound(arr):     srMa = UBound(aMa)
  aCol = Array(0, 1, 3, 4, 10, 11, 14, 16)
  ReDim res(1 To srMa, 1 To 7) 'Ket qua dang Text
  ReDim res2(1 To srMa, 1 To 1) 'Ket qua dang Number
 
  Set dic = CreateObject("Scripting.Dictionary")
  For i = 1 To srMa
    If dic.exists(aMa(i, 1)) = False Then
      dic(aMa(i, 1)) = Array(1, i)
    Else
      a = dic(aMa(i, 1))
      ReDim Preserve a(0 To UBound(a) + 1)
      a(UBound(a)) = i
      dic(aMa(i, 1)) = a
    End If
  Next i
 
  For i = 1 To sR
    If dic.exists(arr(i, 1)) Then
      a = dic(arr(i, 1))
      If a(0) <= UBound(a) + 1 Then
        r = a(a(0))
        a(0) = a(0) + 1
        dic(arr(i, 1)) = a
        For j = 1 To 7
          res(r, j) = arr(i, aCol(j))
        Next j
        res2(r, 1) = arr(i, 14)
      End If
    End If
  Next
  Sheets("Shopee").Range("J2").Resize(srMa, 7).Value = res
  Sheets("Shopee").Range("O2").Resize(srMa, 1).Value = res2
End Sub

Nếu dữ liệu 2 sheet đã xếp thứ tự theo cột A thì không cần dùng Dic và tốc độ nhanh hơn nhiều.

Cảm ơn bạn đã giúp, nếu data ít thì chạy không báo lỗi nhưng khi mình copy dữ liệu nhiều dòng ở Sheet 'Shopee' và Sheet 'Data' vào khi chạy báo lỗi như vậy. Vui lòng giúp sửa lỗi này
Cảm ơn

 

[HieuCD]

Cảm ơn bạn đã giúp, nếu data ít thì chạy không báo lỗi nhưng khi mình copy dữ liệu nhiều dòng ở Sheet 'Shopee' và Sheet 'Data' vào khi chạy báo lỗi như vậy. Vui lòng giúp sửa lỗi này
Cảm ơn

View attachment 307823

Bạn chỉnh dòng lệnh
If a(0) <= UBound(a) + 1 Then

Thành
If a(0) <= UBound(a) Then

 

[sonminhtran]

Bạn chỉnh dòng lệnh
If a(0) <= UBound(a) + 1 Then

Thành
If a(0) <= UBound(a) Then

Cảm ơn bạn đã chạy được dữ liệu