Lọc dữ liệu trùng và tính tổng bằng VBA

[Thanh Bình PV]

Nhờ anh/chị trong GPE giúp em với. Em có dữ liệu từ nhiều sheet "ASSB LIST - A9D-AL2", "ASSB LIST - A9D-AL3", .... Range đều giống nhau C41:G80. E muốn lọc những đối tượng trùng nhau tại cột C và tính tổng của chúng (cột F) rồi đưa dữ liệu qua sheet "SUMMARY - MATERIALS" và cột đơn vị (cột G) sẽ theo cột C.
- Số sheet thay đổi thất thường (40-80 sheet) nhưng tên bắt đầu đều là ASSB LIST. E k đổi tên được vì nó liên quan tới Header ạ.
Em cảm ơn ạ.

 

[snow25]

Nhờ anh/chị trong GPE giúp em với. Em có dữ liệu từ nhiều sheet "ASSB LIST - A9D-AL2", "ASSB LIST - A9D-AL3", .... Range đều giống nhau C41:G80. E muốn lọc những đối tượng trùng nhau tại cột C và tính tổng của chúng (cột F) rồi đưa dữ liệu qua sheet "SUMMARY - MATERIALS" và cột đơn vị (cột G) sẽ theo cột C.
- Số sheet thay đổi thất thường (40-80 sheet) nhưng tên bắt đầu đều là ASSB LIST. E k đổi tên được vì nó liên quan tới Header ạ.
Em cảm ơn ạ.

Bạn thử xem đúng không nhé.

Sub tinhtong()
     Dim sh As Worksheet, i As Long, dic As Object, a As Long, kq(1 To 1000, 1 To 5), b As Long, lr As Long, arr, dk As String
     Set dic = CreateObject("scripting.dictionary")
     For Each sh In ThisWorkbook.Worksheets
         If InStr(1, sh.Name, "ASSB LIST") Then
            arr = sh.Range("C41:G80").Value
            For i = 1 To UBound(arr)
                If arr(i, 1) <> Empty Then
                   dk = UCase(arr(i, 1)) & "#" & UCase(arr(i, 5))
                   If Not dic.exists(dk) Then
                      a = a + 1
                      dic.Add dk, a
                      kq(a, 1) = arr(i, 1)
                      kq(a, 5) = arr(i, 5)
                   End If
                      b = dic.Item(dk)
                      kq(b, 4) = kq(b, 4) + arr(i, 4)
                End If
          Next i
       End If
   Next
   With Sheets("SUMMARY - MATERIALS ")
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        If lr > 22 Then .Range("B23:F" & lr).ClearContents
        If a Then .Range("B23:F23").Resize(a).Value = kq
   End With
End Sub

 

[Thanh Bình PV]

Bạn thử xem đúng không nhé.

Sub tinhtong()
     Dim sh As Worksheet, i As Long, dic As Object, a As Long, kq(1 To 1000, 1 To 5), b As Long, lr As Long, arr, dk As String
     Set dic = CreateObject("scripting.dictionary")
     For Each sh In ThisWorkbook.Worksheets
         If InStr(1, sh.Name, "ASSB LIST") Then
            arr = sh.Range("C41:G80").Value
            For i = 1 To UBound(arr)
                If arr(i, 1) <> Empty Then
                   dk = UCase(arr(i, 1)) & "#" & UCase(arr(i, 5))
                   If Not dic.exists(dk) Then
                      a = a + 1
                      dic.Add dk, a
                      kq(a, 1) = arr(i, 1)
                      kq(a, 5) = arr(i, 5)
                   End If
                      b = dic.Item(dk)
                      kq(b, 4) = kq(b, 4) + arr(i, 4)
                End If
          Next i
       End If
   Next
   With Sheets("SUMMARY - MATERIALS ")
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        If lr > 22 Then .Range("B23:F" & lr).ClearContents
        If a Then .Range("B23:F23").Resize(a).Value = kq
   End With
End Sub

Cảm ơn a nhiều.. Rất đúng ý e. Nhưng a có thể điều chỉnh để add vào button không ạ. E tạo userform để add nó vào thì lại bị lỗi.

Private Sub cmdsumacc_Click()
     Dim sh As Worksheet, i As Long, dic As Object, a As Long, kq(1 To 1000, 1 To 5), b As Long, lr As Long, arr, dk As String
     ....
End Sub