VBA Lọc danh sách tổng hợp thành nhiều DS chi tiết

[chidung2009]

Hiện mình đang muốn lọc 1 danh sách tổng hợp (khoảng 100 hàng) bao gồm tên và chức vụ bằng ngôn ngữ VBA
Mình muốn khi click Button thì nó sẽ tự động lọc từ danh sách tổng hợp thành nhiều danh sách chi tiết theo chức vụ.
Mong anh chị diễn đàn giúp em với
Em xin chân thành cảm ơn

 

[batman1]

Tại sao Lê Hồng Quang xuất hiện 2 lần trong bảng kết quả? Không lấy duy nhất mà có bao nhiêu lần đều lấy hết?

 

[chidung2009]

Tại sao Lê Hồng Quang xuất hiện 2 lần trong bảng kết quả? Không lấy duy nhất mà có bao nhiêu lần đều lấy hết?

Tên trong danh sách là duy nhất, do mình đưa lên nhầm file ạ.

Hiện mình đã tải file lại rồi

 

[chidung2009]

Tại sao Lê Hồng Quang xuất hiện 2 lần trong bảng kết quả? Không lấy duy nhất mà có bao nhiêu lần đều lấy hết?

Mình sử dụng Code dưới để lọc sang danh sách chi tiết, nhưng mới chỉ có lọc được 1 điều kiện. Mong anh chị giúp đỡ sửa code để lọc danh sách theo nhiều điều kiện với ạ

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Dim i As Long, aDuLieu(), KetQua(), K As Long, Jk As Long, iRow As Long, t As Long
    If Target.Column = 3 And Target.Row > 5 And Target.Row < 50 Then
        Dim Dieukien As Variant
        With sHome
            aDuLieu = .Range("B6:C" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
        End With
        ReDim KetQua(1 To UBound(aDuLieu, 1), 1 To 6)
        For i = 1 To UBound(aDuLieu, 1)
            Dieukien = "Th" & ChrW(7849) & "m ph" & ChrW(225) & "n"
            If aDuLieu(i, 2) Like Dieukien Then
                K = K + 1
                KetQua(K, 1) = K
                KetQua(K, 2) = aDuLieu(i, 1)
                KetQua(K, 3) = aDuLieu(i, 2)
            Else
                Jk = Jk + 1
                KetQua(Jk, 4) = Jk
                KetQua(Jk, 5) = aDuLieu(i, 1)
                KetQua(Jk, 6) = aDuLieu(i, 2)
            End If
        Next
        With sHome
            .Range("R6:W48").ClearContents
            If K <> 0 Or Jk <> 0 Then
                .Range("R6").Resize(UBound(KetQua), 6).Value = KetQua
            End If
        End With
        sHome.Range("A6:A48").ClearContents
        For t = 1 To Cells(Rows.Count, 3).End(xlUp).Row - 5
            sHome.Range("A" & t + 5).Value = t
        Next t
    End If
End Sub

 

[batman1]

Code sau chỉ chạy đúng ý khi cột B không có trùng. Nếu có trùng thì phải sửa lại code.

Sub tachCV()
Dim lastRow As Long, r As Long, c As Long, count As Long, chucvu As String, key, dulieu(), ketqua(), CV As Object
    With ThisWorkbook.Worksheets("Sheet1")
        .Range("F6:Z100").ClearContents ' xia ket qua cu
        lastRow = .Cells(Rows.count, "B").End(xlUp).Row ' dong cuoi co du lieu o cot B
        If lastRow < 6 Then Exit Sub
        dulieu = .Range("B6:C" & lastRow).Value             ' lay du lieu vao mang dulieu
    End With
    Set CV = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(dulieu, 1)
        chucvu = dulieu(r, 2)   ' chuc vu
        If CV.exists(chucvu) Then
            ketqua = CV.Item(chucvu)    ' doc ra mang cho chuc vu hien hanh
        Else
            ReDim ketqua(1 To 101, 1 To 3)  ' tao mang moi cho chuc vu hien hanh
        End If
        count = ketqua(101, 1) + 1      ' so nhien vien
        ketqua(count, 1) = count            ' TT
        ketqua(count, 2) = dulieu(r, 1)     ' ho ten
        ketqua(count, 3) = chucvu           ' chuc vu
        ketqua(101, 1) = count                  ' ghi nho mang co bao nhieu dong co du lieu vao phan tu o cot 1 dong 101
        CV.Item(chucvu) = ketqua            ' cho vao tu dien CV
    Next r
    count = 0
    If CV.count Then    ' neu co it nhat 1 chuc vu
        For Each key In CV.keys ' duyet tung chuc vu
            ketqua = CV.Item(key)   ' lay ra mang ung voi chuc vu
            count = count + 1           ' chi so cua mang ket qua hien hanh
            ThisWorkbook.Worksheets("Sheet1").Range("F6").Offset(0, 3 * (count - 1)).Resize(ketqua(101, 1), UBound(ketqua, 2)).Value = ketqua
        Next key
    End If
    
    Set CV = Nothing
End Sub

 

[chidung2009]

Code sau chỉ chạy đúng ý khi cột B không có trùng. Nếu có trùng thì phải sửa lại code.

Sub tachCV()
Dim lastRow As Long, r As Long, c As Long, count As Long, chucvu As String, key, dulieu(), ketqua(), CV As Object
    With ThisWorkbook.Worksheets("Sheet1")
        .Range("F6:Z100").ClearContents ' xia ket qua cu
        lastRow = .Cells(Rows.count, "B").End(xlUp).Row ' dong cuoi co du lieu o cot B
        If lastRow < 6 Then Exit Sub
        dulieu = .Range("B6:C" & lastRow).Value             ' lay du lieu vao mang dulieu
    End With
    Set CV = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(dulieu, 1)
        chucvu = dulieu(r, 2)   ' chuc vu
        If CV.exists(chucvu) Then
            ketqua = CV.Item(chucvu)    ' doc ra mang cho chuc vu hien hanh
        Else
            ReDim ketqua(1 To 101, 1 To 3)  ' tao mang moi cho chuc vu hien hanh
        End If
        count = ketqua(101, 1) + 1      ' so nhien vien
        ketqua(count, 1) = count            ' TT
        ketqua(count, 2) = dulieu(r, 1)     ' ho ten
        ketqua(count, 3) = chucvu           ' chuc vu
        ketqua(101, 1) = count                  ' ghi nho mang co bao nhieu dong co du lieu vao phan tu o cot 1 dong 101
        CV.Item(chucvu) = ketqua            ' cho vao tu dien CV
    Next r
    count = 0
    If CV.count Then    ' neu co it nhat 1 chuc vu
        For Each key In CV.keys ' duyet tung chuc vu
            ketqua = CV.Item(key)   ' lay ra mang ung voi chuc vu
            count = count + 1           ' chi so cua mang ket qua hien hanh
            ThisWorkbook.Worksheets("Sheet1").Range("F6").Offset(0, 3 * (count - 1)).Resize(ketqua(101, 1), UBound(ketqua, 2)).Value = ketqua
        Next key
    End If
   
    Set CV = Nothing
End Sub

Code đã đúng theo ý của mình rồi. Cảm ơn anh batman1 nhiều ạ