Nhờ mọi người giúp đỡ code lọc dữ liệu theo điều kiện từng cột!

[buonphatchan12]

Chào mọi người, em có 2 sheet. Sheet thứ 1 là bảng data, có cột N, mã vật tư, số lượng và tình trạng như hình bên dưới


Và kết quả em cần lọc ra như hình bên dưới với điều kiện là mã vật tư là duy nhất, tình trạng lấy sẽ là giá trị 4, sẽ lấy tổng số lượng theo tên N ở sheet data ( cột N sẽ được paste theo hàng dọc, không cố định là bao nhiêu cột, có thể 10 có thể 50, và sau khi chạy code xong thì cột cuối cùng là cột TOTAL sẽ là tổng số lượng của mã vật tư ở tất cả các giá trị ở cột N

Kết quả muốn em đã để ở file đính kèm, mong mọi người giúp đỡ ạ!

 

[Maika8008]

Chào mọi người, em có 2 sheet. Sheet thứ 1 là bảng data, có cột N, mã vật tư, số lượng và tình trạng như hình bên dưới

View attachment 258739
Và kết quả em cần lọc ra như hình bên dưới với điều kiện là mã vật tư là duy nhất, tình trạng lấy sẽ là giá trị 4, sẽ lấy tổng số lượng theo tên N ở sheet data ( cột N sẽ được paste theo hàng dọc, không cố định là bao nhiêu cột, có thể 10 có thể 50, và sau khi chạy code xong thì cột cuối cùng là cột TOTAL sẽ là tổng số lượng của mã vật tư ở tất cả các giá trị ở cột N
View attachment 258738
Kết quả muốn em đã để ở file đính kèm, mong mọi người giúp đỡ ạ!

Không khó nhưng quả thực là yêu cầu của bạn cũng khá rắc rối.

 

[buonphatchan12]

Không khó nhưng quả thực là yêu cầu của bạn cũng khá rắc rối.

Vâng! Vì thế mà mình nhờ mọi người trên diễn đàn có thể giúp mình ạ.

 

[Maika8008]

Vâng! Vì thế mà mình nhờ mọi người trên diễn đàn có thể giúp mình ạ.

Bạn dùng code này:

Sub LOC_buonphatchan12()
Dim dic1 As Object, dic2 As Object
Dim i As Long, j As Long, k As Long, endR As Long
Dim arrKQ(), arrTD(), arr, arrTong()
Dim strK1 As String, strK2 As String

Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
endR = Sheet1.Range("D" & Rows.Count).End(xlUp).Row
arr = Sheet1.Range("A2:L" & endR)
ReDim arrKQ(1 To UBound(arr, 1), 1 To 3)
ReDim arrTD(1 To 3)
ReDim arrTong(1 To UBound(arr, 1), 1 To 1)
arrTD(1) = "ITEM": arrTD(2) = "ITEM_DESC": arrTD(3) = "UM"
For i = 1 To UBound(arr, 1)
    If arr(i, 9) = 4 Then
        strK1 = arr(i, 4)
        If Not dic1.Exists(strK1) Then
            j = j + 1
            dic1.Add strK1, j
            arrKQ(j, 1) = arr(i, 4)
            arrKQ(j, 2) = arr(i, 5)
            arrKQ(j, 3) = arr(i, 6)
            strK2 = arr(i, 3)
            If arr(i, 9) = 4 Then
                If Not dic2.Exists(strK2) Then
                    k = k + 1
                    dic2.Add strK2, k
                    ReDim Preserve arrKQ(1 To UBound(arr, 1), 1 To 3 + k)
                    ReDim Preserve arrTD(1 To 3 + k)
                    arrKQ(j, 3 + k) = arr(i, 7)
                    arrTD(3 + k) = strK2
                    arrTong(j, 1) = arr(i, 7)
                Else
                    arrKQ(j, 3 + dic2.Item(strK2)) = arrKQ(j, 3 + dic2.Item(strK2)) + arr(i, 7)
                    arrTong(j, 1) = arrTong(j, 1) + arr(i, 7)
                End If
            End If
        Else
            strK2 = arr(i, 3)
            If arr(i, 9) = 4 Then
                If Not dic2.Exists(strK2) Then
                    k = k + 1
                    dic2.Add strK2, k
                    ReDim Preserve arrKQ(1 To UBound(arr, 1), 1 To 3 + k)
                    ReDim Preserve arrTD(1 To 3 + k)
                    arrKQ(dic1.Item(strK1), 3 + k) = arr(i, 7)
                    arrTD(3 + k) = strK2
                    arrTong(dic1.Item(strK1), 1) = arrTong(dic1.Item(strK1), 1) + arr(i, 7)
                Else
                    arrKQ(dic1.Item(strK1), 3 + dic2.Item(strK2)) = arrKQ(dic1.Item(strK1), 3 + dic2.Item(strK2)) + arr(i, 7)
                    arrTong(dic1.Item(strK1), 1) = arrTong(dic1.Item(strK1), 1) + arr(i, 7)
                End If
            End If
        End If
    End If
Next
ReDim Preserve arrKQ(1 To UBound(arr, 1), 1 To 3 + k + 1)
ReDim Preserve arrTD(1 To 3 + k + 1)
arrTD(3 + k + 1) = "TOTAL"

If j Then
    Sheet3.Range("A4").Resize(5000, 200).ClearContents
    Sheet3.Range("A5").Resize(j, 3 + k) = arrKQ
    Sheet3.Range("A4").Resize(1, 3 + k + 1) = arrTD
    Sheet3.Range("A5").Offset(0, 3 + k).Resize(j, 1) = arrTong
End If
End Sub

File kèm:

 

[HieuCD]

Chào mọi người, em có 2 sheet. Sheet thứ 1 là bảng data, có cột N, mã vật tư, số lượng và tình trạng như hình bên dưới

View attachment 258739
Và kết quả em cần lọc ra như hình bên dưới với điều kiện là mã vật tư là duy nhất, tình trạng lấy sẽ là giá trị 4, sẽ lấy tổng số lượng theo tên N ở sheet data ( cột N sẽ được paste theo hàng dọc, không cố định là bao nhiêu cột, có thể 10 có thể 50, và sau khi chạy code xong thì cột cuối cùng là cột TOTAL sẽ là tổng số lượng của mã vật tư ở tất cả các giá trị ở cột N
View attachment 258738
Kết quả muốn em đã để ở file đính kèm, mong mọi người giúp đỡ ạ!

Chạy code

Sub buonphatchanA_Z()
  Dim sArr(), aTD(), Res(), dic As Object
  Dim sRow&, i&, r&, iR&, c&, jC&, iKey$

  Set dic = CreateObject("Scripting.Dictionary")
  With Sheets("data")
    sArr = .Range("C2", .Range("I" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(sArr)
  c = 3
  For i = 1 To sRow
    If sArr(i, 7) = 4 Then
      iKey = sArr(i, 1) & "|||"
      If dic.Exists(iKey) = False Then
        c = c + 1
        dic.Add iKey, c
        ReDim Preserve aTD(1 To 1, 1 To c + 1)
        aTD(1, c) = sArr(i, 1)
      End If
    End If
  Next i
  aTD(1, 1) = "ITEM": aTD(1, 2) = "ITEM_DESC": aTD(1, 3) = "UM": aTD(1, c) = "TOTAL"
  ReDim Res(1 To sRow, 1 To c)
  For i = 1 To sRow
    If sArr(i, 7) = 4 Then
      jC = dic.Item(sArr(i, 1) & "|||")
      iKey = sArr(i, 2) & "#$%"
      If dic.Exists(iKey) = False Then
        r = r + 1
        dic.Add iKey, r
        Res(r, 1) = sArr(i, 2)
        Res(r, 2) = sArr(i, 3)
        Res(r, 3) = sArr(i, 4)
      End If
      iR = dic.Item(iKey)
      Res(iR, jC) = Res(iR, jC) + sArr(i, 5)
      Res(iR, c) = Res(iR, c) + sArr(i, 5)
    End If
  Next i
  With Sheets("ket qua")
    .Range("A4").CurrentRegion.ClearContents
    .Range("A4").Resize(, c) = aTD
    .Range("A5").Resize(r, c) = Res
  End With
End Sub

 

[buonphatchan12]

Để em thử! Em cảm ơn ạ