Nhờ lọc dữ liệu (1 người xem)

[locdx]

Mình có 2 cột dữ liệu, 1 cột ghi mã khách hàng, 1 cột ghi thông tin khách hàng đó có phát sinh tại các khu vực (sheet "chi tiet"). Giờ mình muốn tổng hợp vào sheet "TH", trong đó mỗi khách hàng chỉ còn 1 dòng tương ứng với dòng đó sẽ tổng hợp tất cả các khu vực mà khách hàng có phát sinh. Chi tiết theo file đính kèm.

Mọi người giúp mình xem dùng hàm gì để có kết quả như trên với. Trân thành cảm ơn !

 

[phulien1902]

Mình có 2 cột dữ liệu, 1 cột ghi mã khách hàng, 1 cột ghi thông tin khách hàng đó có phát sinh tại các khu vực (sheet "chi tiet"). Giờ mình muốn tổng hợp vào sheet "TH", trong đó mỗi khách hàng chỉ còn 1 dòng tương ứng với dòng đó sẽ tổng hợp tất cả các khu vực mà khách hàng có phát sinh. Chi tiết theo file đính kèm.

Mọi người giúp mình xem dùng hàm gì để có kết quả như trên với. Trân thành cảm ơn !

Bạn tham khảo Code dưới đây:

Sub locdx()

    Dim Cell As Range
    Dim Dict As Object
    Dim Key As Variant
    Dim i As Long
    Dim Rng As Range
    Dim Wks As Worksheet

    Set Wks = Worksheets("Chi tiet")
    Set Rng = Wks.Range("A1").CurrentRegion

    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare

    For Each Cell In Rng.Columns(1).Cells
        Key = Trim(Cell)
        If Key <> "" Then
            If Not Dict.Exists(Key) Then
                Dict.Add Key, Cell.Offset(0, 1).Text
            Else
                Dict(Key) = Dict(Key) & "," & Cell.Offset(0, 1).Text
                x = Dict(Key)
            End If
        End If
    Next Cell

    Set Wks = Worksheets("TH")
    Set Rng = Wks.Range("A1")

    Wks.Columns("A:B").EntireColumn.ClearContents

    For Each Key In Dict.Keys
        Rng.Offset(i, 0).Value = Key
        Rng.Offset(i, 1).Value = Dict(Key)
        i = i + 1
    Next Key

End Sub

 

[phulien1902]

Quên không gửi bạn File

 

[Ba Tê]

Quên không gửi bạn File

Đã dám "chơi" Dictionary mà không "chơi luôn" mảng, "quếch" 1 phát xuống sheet luôn cho đã.

Sub GPE()
Dim sArr(), dArr(), Dic As Object, I As Long, K As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Chi tiet")
    sArr = .Range(.Range("A2"), .Range("B2").End(xlDown)).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 2)
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1)
    If Not Dic.Exists(Tem) Then
        K = K + 1
        Dic.Add Tem, K
        dArr(K, 1) = Tem
        dArr(K, 2) = sArr(I, 2)
    Else
        dArr(Dic.Item(Tem), 2) = dArr(Dic.Item(Tem), 2) & ", " & sArr(I, 2)
    End If
Next I
Sheets("TH").Range("A2").Resize(K, 2) = dArr
Set Dic = Nothing
End Sub