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

sonminhtran · 10/4/25

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 · 11/4/25

sonminhtran đã viết:
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

Mã:

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 · 11/4/25

HieuCD đã viết:

Kiểm tra lại

Mã:

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 · 11/4/25

sonminhtran đã viết:
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 · 12/4/25

HieuCD đã viết:
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

sonminhtran · 21/4/25

HieuCD đã viết:
Bạn chỉnh dòng lệnh
If a(0) <= UBound(a) + 1 Then

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

Chào bạn,

Hôm nay bên ngành hàng mới thêm 2 cột B và C bên Sheet 'Data'. Do vậy, vui lòng hỗ trợ dò tìm cột A (Sheet Shopee) tham chiếu Sheet Data Cột A nếu có thì lấy dữ liệu, nếu không có thì dò cột B (lấy dữ liệu), nếu cột B không có thì dò cột C (lấy dữ liệu). Các cột còn lại thì vẫn như cũ. Vui lòng xem file đính kèm

Xin cảm ơn

HieuCD · 23/4/25

sonminhtran đã viết:
Chào bạn,

Hôm nay bên ngành hàng mới thêm 2 cột B và C bên Sheet 'Data'. Do vậy, vui lòng hỗ trợ dò tìm cột A (Sheet Shopee) tham chiếu Sheet Data Cột A nếu có thì lấy dữ liệu, nếu không có thì dò cột B (lấy dữ liệu), nếu cột B không có thì dò cột C (lấy dữ liệu). Các cột còn lại thì vẫn như cũ. Vui lòng xem file đính kèm

View attachment 307939
Xin cảm ơn

Chỉnh lại tí . . .

Mã:

Sub xyz()
  Dim arr(), aMa(), aCol, a, res$(), res2(), dic As Object, key$
  Dim sR&, srMa&, i&, r&, j&, c&
 
  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, 0, 4, 5, 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
    For j = 1 To 3
      key = arr(i, j)
      If dic.exists(key) Then
        a = dic(key)
        r = a(a(0))
        res(r, 1) = key
        For c = 2 To 7
          res(r, c) = arr(i, aCol(c))
        Next c
        res2(r, 1) = arr(i, 14)
        If a(0) < UBound(a) Then
          a(0) = a(0) + 1
          dic(key) = a
        Else
          dic.Remove (key)
        End If
        Exit For
      End If
    Next j
  Next i
  Sheets("Shopee").Range("J2").Resize(srMa, 7).Value = res
  Sheets("Shopee").Range("O2").Resize(srMa, 1).Value = res2
End Sub

sonminhtran · Thứ năm lúc 11:50

HieuCD đã viết:

Chỉnh lại tí . . .

Mã:

Sub xyz()
  Dim arr(), aMa(), aCol, a, res$(), res2(), dic As Object, key$
  Dim sR&, srMa&, i&, r&, j&, c&
 
  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, 0, 4, 5, 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
    For j = 1 To 3
      key = arr(i, j)
      If dic.exists(key) Then
        a = dic(key)
        r = a(a(0))
        res(r, 1) = key
        For c = 2 To 7
          res(r, c) = arr(i, aCol(c))
        Next c
        res2(r, 1) = arr(i, 14)
        If a(0) < UBound(a) Then
          a(0) = a(0) + 1
          dic(key) = a
        Else
          dic.Remove (key)
        End If
        Exit For
      End If
    Next j
  Next i
  Sheets("Shopee").Range("J2").Resize(srMa, 7).Value = res
  Sheets("Shopee").Range("O2").Resize(srMa, 1).Value = res2
End Sub

Cảm ơn bạn lần nữa đã hỗ trợ, mình làm được như bạn gửi

ABC2212 · Thứ năm lúc 14:04

HieuCD đã viết:

Chỉnh lại tí . . .

Mã:

Sub xyz()
  Dim arr(), aMa(), aCol, a, res$(), res2(), dic As Object, key$
  Dim sR&, srMa&, i&, r&, j&, c&
 
  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, 0, 4, 5, 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
    For j = 1 To 3
      key = arr(i, j)
      If dic.exists(key) Then
        a = dic(key)
        r = a(a(0))
        res(r, 1) = key
        For c = 2 To 7
          res(r, c) = arr(i, aCol(c))
        Next c
        res2(r, 1) = arr(i, 14)
        If a(0) < UBound(a) Then
          a(0) = a(0) + 1
          dic(key) = a
        Else
          dic.Remove (key)
        End If
        Exit For
      End If
    Next j
  Next i
  Sheets("Shopee").Range("J2").Resize(srMa, 7).Value = res
  Sheets("Shopee").Range("O2").Resize(srMa, 1).Value = res2
End Sub

Cho mình hỏi một chút với, mọi người lắp mã này sau đó chạy code như thế nào vậy ạ!

tambv2012 · Thứ sáu lúc 13:05

Data mẫu bạn

sonminhtran đã viết:
Chào bạn,

Hôm nay bên ngành hàng mới thêm 2 cột B và C bên Sheet 'Data'. Do vậy, vui lòng hỗ trợ dò tìm cột A (Sheet Shopee) tham chiếu Sheet Data Cột A nếu có thì lấy dữ liệu, nếu không có thì dò cột B (lấy dữ liệu), nếu cột B không có thì dò cột C (lấy dữ liệu). Các cột còn lại thì vẫn như cũ. Vui lòng xem file đính kèm

View attachment 307939
Xin cảm ơn

Data mẫu xuất từ phần mền Netsuite ra đúng k Bạn ơi?

sonminhtran · Thứ sáu lúc 23:53

tambv2012 đã viết:
Data mẫu bạn

Data mẫu xuất từ phần mền Netsuite ra đúng k Bạn ơi?

Đúng, data này xuất từ hệ thống Netsuite

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

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

sonminhtran

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

sonminhtran

Thành viên mới

HieuCD

Chuyên gia GPE

sonminhtran

Thành viên mới

sonminhtran

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

sonminhtran

Thành viên mới

ABC2212

Thành viên mới

tambv2012

Thành viên mới

sonminhtran

Thành viên mới

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

Đếm ngược thời gian