Hướng Dẫn Group Dữ Liệu

Chia sẻ bởi:hands

★★★★★

‹ Nhờ các bác hỗ trợ giải thuật... Tìm sô lần thay đổi ›

Quảng cáo

Em chào các bác!
Các bác cho hỏi có cách nào group dữ liệu trong excel như hình không ạ. Mong các bác giúp đỡ. 663Em xin cảm ơn rất nhiều!

Làm đại. Nhấn nút "RUN" để chạy code.

Option Explicit
Sub test()
Dim lr&, i&, j&, k&, c&, rng, arr(1 To 100000, 1 To 3), dic As Object, key, f
Set dic = CreateObject("Scripting.dictionary")
lr = Cells(Rows.Count, "B").End(xlUp).Row
With Range("A2:D" & lr)
    .Sort Range("C1")
    rng = .Value
End With
For i = 1 To UBound(rng)
    If Not dic.exists(rng(i, 3)) Then
        dic.Add rng(i, 3), 1
    Else
        dic(rng(i, 3)) = dic(rng(i, 3)) + 1
    End If
Next
k = 1: arr(1, 1) = "STT": arr(1, 2) = "Ho_Ten": arr(1, 3) = "Dia_Chi"
For Each key In dic.keys
    c = 0: k = k + 1: arr(k, 1) = key
    Set f = Range("C2:C" & lr).Find(key)
    If Not f Is Nothing Then
        c = c + 1: k = k + 1
        arr(k, 1) = f.Offset(, -2): arr(k, 2) = f.Offset(, -1): arr(k, 3) = f.Offset(, 1)
        Do While c < dic(key)
            Set f = Range("C2:C" & lr).FindNext(f)
            If Not f Is Nothing Then
                c = c + 1: k = k + 1
                arr(k, 1) = f.Offset(, -2): arr(k, 2) = f.Offset(, -1): arr(k, 3) = f.Offset(, 1)
            End If
        Loop
    End If
Next
With Range("J1:L10000")
    .ClearContents
    .Font.Bold = False
End With
Range("J1").Resize(k, 3).Value = arr
For i = 2 To k
    If IsDate(Cells(i, "J")) Then Cells(i, "J").Font.Bold = True
Next
End Sub