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

[misibi]

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 đỡ. Em xin cảm ơn rất nhiều!

 

[BuiQuangThuan]

Thử với pivotable coi thế nào

 

[misibi]

Thử với pivotable coi thế nào

Chạy ko ra được như kết quả ạ

 

[bebo021999]

Dùng VBA được không bạn?

 

[hocexcel_1991]

Nếu bán dùng Exce365 thì có thể dùng công thức hoặc Exce 2013+ thì dùng Power Query.

 

[hoangtuaotrang_hp_vn]

Chạy ko ra được như kết quả ạ

Pivottable cũng ra được gần giống rùi mà nhỉ?

 

[misibi]

Use VBA được không bạn?

Dạ được anh ơi. Mong anh giúp đỡ!

 

[bebo021999]

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

 

[Phương Thanh103]

Pivot ngày+STT thôi, còn tên và Địa chỉ thì mình dò:

 

[BuiQuangThuan]

Góp vui thêm cách khác

Sub ABC()
    Dim sArr(), Res(), i&, Key, S, K&
    Dim Dic As Object:      Set Dic = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet1")
        sArr = .Range("A2:D" & .Range("B" & Rows.Count).End(3).Row).Value
        ReDim Res(1 To 10000, 1 To 3)
        For i = 1 To UBound(sArr)
            Dic(sArr(i, 3)) = Dic(sArr(i, 3)) & "," & i
        Next
        For Each Key In Dic.Keys
            S = Split(Dic(Key), ",")
            K = K + 1
            Res(K, 1) = Key
            For i = 1 To UBound(S)
                K = K + 1
                Res(K, 1) = sArr(CLng(S(i)), 1)
                Res(K, 2) = sArr(CLng(S(i)), 2)
                Res(K, 3) = sArr(CLng(S(i)), 4)
            Next
        Next
        .Range("M2").Resize(K, 3).Value = Res
    End With
End Sub

 

[misibi]

Làm đại. Click vào "RUN" để chạy mã.

[code = VBA]
Tùy chọn rõ ràng
Kiểm tra phụ ()
Dim lr &, i &, j &, k &, c &, rng, arr (1 To 100000, 1 to 3), dic As Object, key, f
Đặt dic = CreateObject ("Scripting.dictionary")
lr = Cells (Rows.Count, "B"). End (xlUp) .Row
Với Phạm vi ("A2: D" & lr)
.Sort Range ("C1")
rng = .Value
Kết thúc với
Đối với i = 1 Đến UBound (rng)
If Not dic.exists (rng (i, 3)) Thì
dic.Thêm rng (i, 3), 1
Khác
dic (rng (i, 3)) = dic (rng (i, 3)) + 1
Kết thúc nếu
Tiếp theo
k = 1: arr (1, 1) = "STT": arr (1, 2) = "Ho_Ten": arr (1, 3) = "Dia_Chi"
Đối với mỗi phím Trong dic.keys
c = 0: k = k + 1: arr (k, 1) = phím
Đặt f = Range ("C2: C" & lr) .Find (key)
Nếu không f là không có gì thì
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)
Đặt f = Range ("C2: C" & lr) .FindNext (f)
Nếu không f là không có gì thì
c = c + 1: k = k + 1
arr (k, 1) = f.Offset (, -2): arr (k, 2) = f.Offset (, -1): arr (k, 3) = f.Offset (, 1)
Kết thúc nếu
Vòng
Kết thúc nếu
Tiếp theo
Với Phạm vi ("J1: L10000")
.Xóa nội dung
.Font.Bold = Sai
Kết thúc với
Phạm vi ("J1"). Thay đổi kích thước (k, 3) .Value = arr
Đối với i = 2 Đến k
If IsDate (Cells (i, "J")) Then Cells (i, "J"). Font.Bold = True
Tiếp theo
Kết thúc Sub
[/mã số]

Em xin cám ơn anh rất nhiều!