Gửi Tin Nhắn Cho Admin

Thứ Sáu, 6 tháng 10, 2017

Tổng hợp các dữ liệu Trùng và Cộng Dồn Theo điều kiện

Phạm Minh Tùng  /  at  10/06/2017 10:55:00 SA  /  No comments

- Đây là yêu cầu của đề bài:

- và đây là kết quả cần xuất ra
- Code:
-----------------------------------------------------------------------------------------------------------------
Sub UniqueData()
    Dim dongcuoi As Long, arrdata As Variant, dic As Object
    Dim i As Long, kq As Variant, k As Long, j As Byte
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheet1
        dongcuoi = .Range("b65536").End(3).Row
        arrdata = .Range("b2:E" & dongcuoi).Value
    End With
    For i = 1 To UBound(arrdata)
        dic(arrdata(i, 1) & arrdata(i, 2)) = ""
    Next i
    ReDim kq(1 To dic.Count, 1 To 4)
    dic.RemoveAll
    For i = 1 To UBound(arrdata)
        If Not dic.exists(arrdata(i, 1) & arrdata(i, 2)) Then
            k = k + 1
            dic.Add arrdata(i, 1) & arrdata(i, 2), k
            For j = 1 To 4
                kq(k, j) = arrdata(i, j)
            Next j
        Else
            kq(dic.Item(arrdata(i, 1) & arrdata(i, 2)), 3) = _
                kq(dic.Item(arrdata(i, 1) & arrdata(i, 2)), 3) + arrdata(i, 3)
            kq(dic.Item(arrdata(i, 1) & arrdata(i, 2)), 4) = _
                kq(dic.Item(arrdata(i, 1) & arrdata(i, 2)), 4) + arrdata(i, 4)
        End If
    Next i
    With Sheet2
        .Range("2:65536").ClearContents
        .Range("B2").Resize(k, 4).Value = kq
    End With
    msgbox "Done!"
End Sub
-----------------------------------------------------------------------------------------------------------------
- Cách thực hiện: các bạn tạo 1 nút bấm và gán macro cho nó, như video bên dưới:

Share
Posted in: , Posted on: Thứ Sáu, 6 tháng 10, 2017

0 nhận xét:

Recent Comments

Copyright © 2013 Excel Toàn Tập. WP Theme-junkie converted by Bloggertheme9
Blogger templates. Proudly Powered by Blogger.