Lọc mã hàng theo danh sách cho trước.

Chia sẻ bởi:hands

★★★★★

‹ Nhờ giúp đỡ lọc không trùng và... Nối các ô dữ liệu trong các... ›

Quảng cáo

Xin chào các Bạn,

Mình cần các bạn hỗ trợ viết dùm mình code vba lọc Mã Hàng theo danh sách cho trước.

Từ bảng sheet DATA dựa vào Mã Hàng tại sheet Kết Quả cho trước lọc được Mã Hàng theo mẫu kết quả từ ô G2 tại sheet Kết Quả, mong các bạn xem giúp đỡ.

Xin cám ơn các Bạn,

640

Bạn tham khảo :

Option Explicit

Sub T_T()

Dim dic As Object
    Dim sheet As Worksheet
    Dim data As Variant, result As Variant
    Dim sCode As String, sCust As String
    Dim i As Long, k As Long, r As Long, c As Long
    Dim dbQty As Double

With ThisWorkbook.Worksheets("DATA")
        r = .Cells(.Rows.Count, "M").End(xlUp).Row
        If (r < 2) Then Exit Sub
        data = .Range("M2:Q" & r).Value
    End With

Set sheet = ThisWorkbook.Worksheets("Ket_Qua")
    r = sheet.Cells(sheet.Rows.Count, "C").End(xlUp).Row + 1
    If (r < 3) Then Exit Sub
    result = sheet.Range("C2:D" & r).Value
    r = UBound(result, 1)

Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(result, 1) + 1 To UBound(result, 1)
        If (i < r) Then
            dic.Add result(i, 1), i
        Else
            result(i, 1) = "Grand Total"
        End If
    Next i

For i = LBound(data, 1) To UBound(data, 1)
        sCode = data(i, 1)
        dbQty = data(i, 4)
        sCust = data(i, 5)
        If dic.Exists(sCode) Then
            k = dic.Item(sCode)
            If Not dic.Exists(sCust) Then
                c = UBound(result, 2) + 1
                ReDim Preserve result(1 To r, 1 To c)
                dic.Add sCust, c
                result(1, c) = sCust
                result(k, c) = dbQty
            Else
                c = dic.Item(sCust)
                result(k, c) = result(k, c) + dbQty
            End If
            result(r, c) = result(r, c) + dbQty
        End If
    Next i
    c = UBound(result, 2) + 1
    ReDim Preserve result(1 To r, 1 To c)
    result(1, c) = "Grand Total"

For i = 2 To r
        For k = 3 To c - 1
            result(i, c) = result(i, c) + result(i, k)
        Next k
    Next i

sheet.Range("G13").Resize(r, c).Value = result

End Sub

www.giaiphapexcel.com/diendan/threads/l%E1%BB%8Dc-m%C3%A3-h%C3%A0ng-theo-danh-s%C3%A1ch-cho-tr%C6%B0%E1%BB%9Bc.163440/post-1090236

Thêm cách khác tham khảo. Phần Grand tự làm lấy

Option Explicit
Sub ABC()
    Dim Dic As Object, sArr(), Res(), aTieuDe(), i&, iRow&, m&
    Set Dic = CreateObject("scripting.dictionary")
    With Sheets("Ket_Qua")
        iRow = .Range("C" & Rows.Count).End(3).Row
        sArr = .Range("C2:D" & iRow).Value
        ReDim Res(1 To UBound(sArr) - 1, 1 To 1000)
        For i = 2 To UBound(sArr)
            Dic(sArr(i, 1)) = i
        Next
    End With
    With Sheets("DATA")
        iRow = .Range("M" & Rows.Count).End(3).Row
        sArr = .Range("A2:Q" & iRow).Value
        For i = 1 To UBound(sArr)
            If Dic.Exists(sArr(i, 13)) = True Then
                If Dic.Exists(sArr(i, 17)) = False Then
                    m = m + 1
                    Dic(sArr(i, 17)) = m
                    ReDim Preserve aTieuDe(1 To m)
                    aTieuDe(m) = sArr(i, 17)
                End If
                Res(Dic(sArr(i, 13)) - 1, Dic(sArr(i, 17))) = Res(Dic(sArr(i, 13)) - 1, Dic(sArr(i, 17))) + sArr(i, 16)
            End If
        Next
    End With
    With Sheets("Ket_Qua")
        .Range("E2").Resize(, UBound(aTieuDe)).Value = aTieuDe
        .Range("E3").Resize(UBound(Res), m + 2).Value = Res
    End With
End Sub

www.giaiphapexcel.com/diendan/threads/l%E1%BB%8Dc-m%C3%A3-h%C3%A0ng-theo-danh-s%C3%A1ch-cho-tr%C6%B0%E1%BB%9Bc.163440/post-1090238

Một cách khác:
Click vô nút "LOC" để chạy.

Option Explicit
Sub locmahang()
Dim lr&, lr2&, lc&, i&, rng, res(), dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheets("DATA")
lr = .Cells(Rows.Count, "M").End(xlUp).Row
rng = .Range("Q2:Q" & lr).Value
On Error Resume Next
For i = 1 To UBound(rng)
dic.Add rng(i, 1), ""
Next
End With
With Sheets("Ket_Qua")
lr2 = .Cells(Rows.Count, "C").End(xlUp).Row
.Range("E2:XX10000").ClearContents
.Range("E2").Resize(1, dic.Count).Value = dic.keys
lc = .Range("XX2").End(xlToLeft).Offset(, 1).Column
.Cells(2, lc).Value = "Grand Total"
.Range("E3", .Cells(lr2, lc – 1)).Formula = "=SUMIFS(DATA!$P$2:$P$" & lr & ",DATA!$M$2:$M$" & lr & ",$C3,DATA!$Q$2:$Q$" & lr & ",E$2)"
.Range(.Cells(3, lc), .Cells(lr2, lc)).FormulaR1C1 = "=SUM(RC:RC)"
.Cells(lr2 + 1, "D").Value = "Grand Total"
.Range(.Cells(lr2 + 1, "E"), .Cells(lr2 + 1, lc)).FormulaR1C1 = "=SUM(RC:RC)" '"=SUM( E3:E9)"
.Range("E3", .Cells(lr2 + 1, lc)).Value = .Range("E3", .Cells(lr2 + 1, lc)).Value
With .Range("C2", .Cells(lr2 + 1, lc))
.EntireColumn.AutoFit
.Borders.LineStyle = xlContinuous
End With
End With
Set dic = Nothing
End Sub