Lọc dữ liệu khách hàng theo mã hàng.

[huyngo19888]

Thân gửi các bác,

Em có 1 line dữ liệu gồm mã hàng + khách hàng, rất dài. e cần lọc dữ liệu khách hàng theo cùng 1 mã hàng trong cùng 1 hàng như file đính kèm. Nhờ các bác hướng dẫn em với ạ.

Em cảm ơn.

 

[snow25]

Thân gửi các bác,

Em có 1 line dữ liệu gồm mã hàng + khách hàng, rất dài. e cần lọc dữ liệu khách hàng theo cùng 1 mã hàng trong cùng 1 hàng như file đính kèm. Nhờ các bác hướng dẫn em với ạ.

Em cảm ơn.

Thử cái code này.

Sub abc()
   Dim i As Long, lr As Long, dic As Object, a As Long, b As Long, arr, kq, dk As String
   Set dic = CreateObject("scripting.dictionary")
   With Sheets("sheet1")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A4:B" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To 2)
        For i = 1 To UBound(arr)
            dk = arr(i, 1)
            If Not dic.exists(dk) Then
               a = a + 1
               dic.Add dk, a
               kq(a, 1) = arr(i, 1)
               kq(a, 2) = arr(i, 2)
             Else
                b = dic.Item(dk)
                kq(b, 2) = kq(b, 2) & "," & arr(i, 2)
             End If
        Next i
        lr = .Range("F" & Rows.Count).End(xlUp).Row
        If lr > 3 Then .Range("F4:G" & lr).ClearContents
        .Range("F4:G4").Resize(a).Value = kq
   End With
   Set dic = Nothing
End Sub

 

[huyngo19888]

Thử cái code này.

Sub abc()
   Dim i As Long, lr As Long, dic As Object, a As Long, b As Long, arr, kq, dk As String
   Set dic = CreateObject("scripting.dictionary")
   With Sheets("sheet1")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A4:B" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To 2)
        For i = 1 To UBound(arr)
            dk = arr(i, 1)
            If Not dic.exists(dk) Then
               a = a + 1
               dic.Add dk, a
               kq(a, 1) = arr(i, 1)
               kq(a, 2) = arr(i, 2)
             Else
                b = dic.Item(dk)
                kq(b, 2) = kq(b, 2) & "," & arr(i, 2)
             End If
        Next i
        lr = .Range("F" & Rows.Count).End(xlUp).Row
        If lr > 3 Then .Range("F4:G" & lr).ClearContents
        .Range("F4:G4").Resize(a).Value = kq
   End With
   Set dic = Nothing
End Sub

bác làm dùm em file excel với. sao e làm run không được ạ. e cảm ơn.

 

[HUONGHCKT]

Thân gửi các bác,

Em có 1 line dữ liệu gồm mã hàng + khách hàng, rất dài. e cần lọc dữ liệu khách hàng theo cùng 1 mã hàng trong cùng 1 hàng như file đính kèm. Nhờ các bác hướng dẫn em với ạ.

Em cảm ơn.

Xem file. nhấn nút Lọc để xem và kiểm tra kết quả. Các nội dung khác (định dạng, kẻ khung...) bạn tự làm.

 

[huyngo19888]

Xem file. nhấn nút Lọc để xem và kiểm tra kết quả. Các nội dung khác (định dạng, kẻ khung...) bạn tự làm.

Bác giúp e thêm chỗ này với. Ví dụ cột A, B e lỡ nhập trùng nhau, khi lọc kết quả khách hàng nó bỏ trùng đi. thể hiện 1 khách hàng thôi thì làm sao ạ. em cảm ơn.

 

[HUONGHCKT]

Bác giúp e thêm chỗ này với. Ví dụ cột A, B e lỡ nhập trùng nhau, khi lọc kết quả khách hàng nó bỏ trùng đi. thể hiện 1 khách hàng thôi thì làm sao ạ. em cảm ơn.

View attachment 278140

Của bạn đây.
Xem file đính kèm

 

[snow25]

Của bạn đây.
Xem file đính kèm

Sao không dùng luôn hàm Instr để kiểm tra mà lại phải viết thêm 1 code xóa ký tự vậy.

 

[HUONGHCKT]

Sao không dùng luôn hàm Instr để kiểm tra mà lại phải viết thêm 1 code xóa ký tự vậy.

Cảm ơn anh đã xem bài. Thực tình là tôi không nghĩ ra giải pháp thông minh ấy. nên mày mò (mất tương đối thời gian) để viết lại một hàm để xóa. Giờ anh gợi ý tôi mới chợt nghĩ đến. Hy vọng chủ thớt đọc đến bài #7 của anh sẽ biết cách sửa code theo hướng anh đã gợi ý.

 

[bebo021999]

Của bạn đây.
Xem file đính kèm

Vẫn còn trùng nè bạn ơi

 

[HUONGHCKT]

Vẫn còn trùng nè bạn ơi

Cảm ơn bạn đã xem bài.
Tôi nhầm chỗ này.

End If
    Res(t,2) = XoaKT(Res(t, 2))
Next i

mà phải là mới đúng

End If
    Res(k, 2) = XoaKT(Res(k, 2))
Next i

sửa lại code theo ý anh @snow gợi ý.

Option Explicit

Sub Loc()
Dim i&, j&, t&, k&, a&, b&, Lr&, R&
Dim Arr(), Res(), S
Dim Dic As Object, Tmp
Dim Dict As Object

Application.ScreenUpdating = False
With Sheet1
    Lr = .Cells(Rows.Count, 2).End(xlUp).Row
    Arr = .Range("A3:B" & Lr).Value
    R = UBound(Arr)
Set Dic = CreateObject("Scripting.Dictionary")
Set Dict = CreateObject("Scripting.Dictionary")

ReDim Res(1 To R, 1 To 2)
On Error Resume Next
For i = 1 To R
     Tmp = Arr(i, 1)
     If Not Dic.Exists(Tmp) Then
        t = t + 1: Dic.Add (Tmp), t
        Res(t, 1) = Tmp
        Res(t, 2) = Arr(i, 2)
    Else
        k = Dic.Item(Tmp)
        If Len(Res(k, 2)) = 0 Then
            Res(k, 2) = Arr(i, 2)
        Else
            If InStr(1, Res(k, 2), Arr(i, 2)) = 0 Then
                Res(k, 2) = Res(k, 2) & "; " & Arr(i, 2)
            End If
        End If
    End If
  '  Res(k, 2) = XoaKT(Res(k, 2))
Next i
If t Then
    .Range("F3").Resize(1000000, 2).ClearContents
    .Range("F3").Resize(t, 2) = Res
End If

End With
Set Dic = Nothing: Set Dict = Nothing
Application.ScreenUpdating = True
MsgBox "Done", vbInformation, "THÔNG BÁO"
End Sub

lúc này ta không cần hàm XoaKT nữa, có thể xóa bỏ nó trong modul2

 

[bebo021999]

Sub Loc()
Dim i&, j&, t&, k&, a&, b&, Lr&, R&
Dim Arr(), Res(), S
Dim Dic As Object, Tmp
Dim Dict As Object

Dùng tới 2 dictionary và 2 array cơ à
Theo mình chỉ dùng 1 cái dict là đủ.
Khi nối chuỗi 1 item mới, dùng intr kiểm tra, nếu chưa có thì ghép vô, không thì thôi.
Sau đó in dict ra sheet thôi.

Option Explicit
Sub Loc()
Dim i&, lr&, rng, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
With Sheet1
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A4:B" & lr).Value
    For i = 1 To lr - 3
        If Not dic.Exists(rng(i, 1)) Then
            dic.Add rng(i, 1), rng(i, 2)
        Else
            dic(rng(i, 1)) = dic(rng(i, 1)) & IIf(InStr(1, dic(rng(i, 1)), rng(i, 2)), _
            "", ";" & rng(i, 2))
        End If
    Next
    .Range("F4").Resize(dic.Count, 1) = WorksheetFunction.Transpose(dic.keys)
    .Range("G4").Resize(dic.Count, 1) = WorksheetFunction.Transpose(dic.items)
End With
Set dic = Nothing
End Sub

 

[tranhungdao12a3]

Viết một hàm Dax như vầy là giải quyết được bài toán nhé bạn:
Ghép:=CONCATENATEX('Table1','Table1'[Khách hàng]," ,")

 

[vanthinh3101]

Bác giúp e thêm chỗ này với. Ví dụ cột A, B e lỡ nhập trùng nhau, khi lọc kết quả khách hàng nó bỏ trùng đi. thể hiện 1 khách hàng thôi thì làm sao ạ. em cảm ơn.

View attachment 278140

Code phức tạp thì bạn có thể tìm hiểu dùng Power Query.
Tham khảo file đính kèm.

 

[Nhattanktnn]

Viết một hàm Dax như vầy là giải quyết được bài toán nhé bạn:
Ghép:=CONCATENATEX('Table1','Table1'[Khách hàng]," ,")

Theo như yêu cầu của bài #5, vậy hàm này phải lồng distinct vào nữa

 

[tranhungdao12a3]

Theo như yêu cầu của bài #5, vậy hàm này phải lồng distinct vào nữa

À do tôi không đọc những bài bên dưới, nếu bỏ trùng bên danh sách khách hàng thì thêm Distinct hay values đều được:
Ghép#5:=CONCATENATEX(distinct(Table1[Khách hàng]),'Table1'[Khách hàng]," ,")
Ghép#5:=CONCATENATEX(VALUES(Table1[Khách hàng]),'Table1'[Khách hàng]," ,")

 

[HUONGHCKT]

Dùng tới 2 dictionary và 2 array cơ à
Theo mình chỉ dùng 1 cái dict là đủ.
Khi nối chuỗi 1 item mới, dùng intr kiểm tra, nếu chưa có thì ghép vô, không thì thôi.
Sau đó in dict ra sheet thôi.

Option Explicit
Sub Loc()
Dim i&, lr&, rng, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
With Sheet1
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A4:B" & lr).Value
    For i = 1 To lr - 3
        If Not dic.Exists(rng(i, 1)) Then
            dic.Add rng(i, 1), rng(i, 2)
        Else
            dic(rng(i, 1)) = dic(rng(i, 1)) & IIf(InStr(1, dic(rng(i, 1)), rng(i, 2)), _
            "", ";" & rng(i, 2))
        End If
    Next
    .Range("F4").Resize(dic.Count, 1) = WorksheetFunction.Transpose(dic.keys)
    .Range("G4").Resize(dic.Count, 1) = WorksheetFunction.Transpose(dic.items)
End With
Set dic = Nothing
End Sub

Dict thừa ấy mà. Trong code có dùng đến nó đâu (trường hợp dùng hàm XoaKT thì mói dùng đến nó).

 

[Maika8008]

Dùng tới 2 dictionary và 2 array cơ à
Theo mình chỉ dùng 1 cái dict là đủ.
Khi nối chuỗi 1 item mới, dùng intr kiểm tra, nếu chưa có thì ghép vô, không thì thôi.
Sau đó in dict ra sheet thôi.

Option Explicit
Sub Loc()
Dim i&, lr&, rng, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
With Sheet1
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A4:B" & lr).Value
    For i = 1 To lr - 3
        If Not dic.Exists(rng(i, 1)) Then
            dic.Add rng(i, 1), rng(i, 2)
        Else
            dic(rng(i, 1)) = dic(rng(i, 1)) & IIf(InStr(1, dic(rng(i, 1)), rng(i, 2)), _
            "", ";" & rng(i, 2))
        End If
    Next
    .Range("F4").Resize(dic.Count, 1) = WorksheetFunction.Transpose(dic.keys)
    .Range("G4").Resize(dic.Count, 1) = WorksheetFunction.Transpose(dic.items)
End With
Set dic = Nothing
End Sub

Rất gọn. Để khi nào vào máy tính xem code hoạt động, học cái chiêu này.

 

[Nhattanktnn]

Rất gọn. Để khi nào vào máy tính xem code hoạt động, học cái chiêu này.

Bài này phải đọc hiểu luôn chứ bác hihi. Mấu chốt là cứ add key (mã hàng), với item là khách hàng.
Key chưa có thì cứ add item bình thường, có rồi thì nối item cũ với khách hàng tại dòng đang xét. Nhưng trước khi nối thì xét item đó đã chứa khách hàng đó hay chưa là được (dùng instr).

 

[HieuCD]

Dữ liệu đã sort theo mã hàng không dùng dic hiệu quả hơn nhiều

 

[kbw1]

Code phức tạp thì bạn có thể tìm hiểu dùng Power Query.
Tham khảo file đính kèm.

Đoạn group by, bác gõ lệnh chứ không dùng thao tác ạ,
Nếu dùng thao tác bác có thể hướng dẫn em ko ạ.
Em làm đến đây rồi mà ko làm được tiếp.