filter họ tên và email

[bicutit]

Chào các bác,
Em có 1 dữ liệu 1000 học sinh, gồm 2 cột là cột họ tên học sinh và cột email
Em mong muốn là tên học sinh được ưu tiên xếp theo thứ tự abc, tuy nhiên có nhiều học sinh trong cùng 1 gia đình ( dựa vào email của phụ huynh )
Thì khi gặp học sinh trong cùng 1 gia đình ( cùng email thì sẽ xếp cạnh nhau)
em gửi ví dụ ở file đính kèm, làm sao để từ sheet1 có thể dùng macro hoặc lọc như thế nào để ra được sheet ket qua
Mong các bác giúp đỡ,
cảm ơn

 

[snow25]

Chào các bác,
Em có 1 dữ liệu 1000 học sinh, gồm 2 cột là cột họ tên học sinh và cột email
Em mong muốn là tên học sinh được ưu tiên xếp theo thứ tự abc, tuy nhiên có nhiều học sinh trong cùng 1 gia đình ( dựa vào email của phụ huynh )
Thì khi gặp học sinh trong cùng 1 gia đình ( cùng email thì sẽ xếp cạnh nhau)
em gửi ví dụ ở file đính kèm, làm sao để từ sheet1 có thể dùng macro hoặc lọc như thế nào để ra được sheet ket qua
Mong các bác giúp đỡ,
cảm ơn

Bạn thử code này xem có đúng không.

Sub sapxep()
    Dim arr, kq, i As Long, dk As String, lr As Long, dic As Object, data, T, k As Integer, a As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         .Range("A2:B" & lr).Sort .Range("a2"), 1
         arr = .Range("A2:B" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To 2)
         For i = 1 To UBound(arr)
             dk = arr(i, 2)
             dic.Item(dk) = dic.Item(dk) & "#" & i
         Next i
         data = dic.keys
         For i = LBound(data) To UBound(data)
             T = Split(dic.Item(data(i)), "#")
             For k = 1 To UBound(T)
                 a = a + 1
                 kq(a, 1) = arr(T(k), 1)
                 kq(a, 2) = arr(T(k), 2)
             Next k
        Next i
   End With
   With Sheets("ketqua")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        If lr > 2 Then .Range("A2:B" & lr).ClearContents
        If a Then .Range("A2:B2").Resize(a).Value = kq
   End With
End Sub

 

[bicutit]

Bạn thử code này xem có đúng không.

Sub sapxep()
    Dim arr, kq, i As Long, dk As String, lr As Long, dic As Object, data, T, k As Integer, a As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         .Range("A2:B" & lr).Sort .Range("a2"), 1
         arr = .Range("A2:B" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To 2)
         For i = 1 To UBound(arr)
             dk = arr(i, 2)
             dic.Item(dk) = dic.Item(dk) & "#" & i
         Next i
         data = dic.keys
         For i = LBound(data) To UBound(data)
             T = Split(dic.Item(data(i)), "#")
             For k = 1 To UBound(T)
                 a = a + 1
                 kq(a, 1) = arr(T(k), 1)
                 kq(a, 2) = arr(T(k), 2)
             Next k
        Next i
   End With
   With Sheets("ketqua")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        If lr > 2 Then .Range("A2:B" & lr).ClearContents
        If a Then .Range("A2:B2").Resize(a).Value = kq
   End With
End Sub

đúng rồi ạ, bác giỏi quá, em chẳng hiểu nổi mấy cái lệnh này...