Xin trợ giúp code lọc dữ liệu trong bảng

[bienda]

Tình hình là em có bảng giá trị A:F (bảng 1)
Các bác cao thủ giúp em cái sub lọc lấy giá trị từ bảng 1 sang bảng 2 (H:M) như trong file excel đính kèm

Em xin cảm ơn các bác rất nhiều

 

[HieuCD]

Tình hình là em có bảng giá trị A:F (bảng 1)
Các bác cao thủ giúp em cái sub lọc lấy giá trị từ bảng 1 sang bảng 2 (H:M) như trong file excel đính kèm

Em xin cảm ơn các bác rất nhiều

Tiêu đề hơi bị phạm qui, lần sau nhớ đọc nội qui

Sub GPE()
  Dim dArr As Variant, Arr As Variant
  Dim i As Long, k As Long, ik As Long, iRow As Long
  Dim key As String
  i = Range("A" & Rows.Count).End(xlUp).Row
  If i < 2 Then MsgBox ("khong co du lieu, khong loc"): Exit Sub
  dArr = Range("A2:Y" & i).Value
  ReDim Arr(1 To UBound(dArr), 1 To 6)
  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(dArr)
      key = dArr(i, 2) & "-" & dArr(i, 1) & "-" & dArr(i, 3)
      If Not .exists(key) Then
        k = k + 1
        .Add key, Array(k, 0)
        Arr(k, 1) = k: Arr(k, 2) = key
        Arr(k, 3) = dArr(i, 5): Arr(k, 4) = dArr(i, 6)
      Else
        .Item(key) = Array(.Item(key)(0), i)
      End If
    Next i
    For i = 1 To k
      key = Arr(i, 2)
      iRow = .Item(key)(1)
      If iRow Then
        ik = .Item(key)(0)
        Arr(ik, 5) = dArr(iRow, 5): Arr(ik, 6) = dArr(iRow, 6)
      End If
    Next i
  End With
  i = Range("H" & Rows.Count).End(xlUp).Row
  If i > 1 Then Range("H2:M" & i).ClearContents
  Range("H2").Resize(k, 6) = Arr
End Sub

 

[bienda]

Cảm ơn bác HieuCD nhiều ạ. Em sẽ rút kinh nghiệm về nội quy post bài.
Code của bác xài Dict đọc khó hiểu quá (Em đang phải tìm hiểu về Dict để tường minh code của bác). Đúng là cao thủ có khác
Một lần nửa em xin cám ơn

 

[bienda]

Bác HieuCD ơi, làm sao để cho kết quả sang 1 sheet khác. Em loay hoay mãi chưa biết cách làm

Em làm được rồi bác HieuCD ạ, cảm ơn bác lần nữa