Lọc dữ liệu khách hàng theo mã hàng.

huyngo19888 · 30/6/22

Thân gửi các bác,

Em có 1 line dữ liệu gồm mã hàng + khách hàng, rất dài. e cần lọc dữ liệu khách hàng theo cùng 1 mã hàng trong cùng 1 hàng như file đính kèm. Nhờ các bác hướng dẫn em với ạ.

Em cảm ơn.

snow25 · 30/6/22

huyngo19888 đã viết:
Thân gửi các bác,

Em có 1 line dữ liệu gồm mã hàng + khách hàng, rất dài. e cần lọc dữ liệu khách hàng theo cùng 1 mã hàng trong cùng 1 hàng như file đính kèm. Nhờ các bác hướng dẫn em với ạ.

Em cảm ơn.

Thử cái code này.

Mã:

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 · 30/6/22

snow25 đã viết:

Thử cái code này.

Mã:

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

bác làm dùm em file excel với. sao e làm run không được ạ. e cảm ơn.

HUONGHCKT · 30/6/22

huyngo19888 đã viết:
Thân gửi các bác,

Em có 1 line dữ liệu gồm mã hàng + khách hàng, rất dài. e cần lọc dữ liệu khách hàng theo cùng 1 mã hàng trong cùng 1 hàng như file đính kèm. Nhờ các bác hướng dẫn em với ạ.

Em cả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 · 30/6/22

HUONGHCKT đã viết:
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.

Bác giúp e thêm chỗ này với. Ví dụ cột A, B e lỡ nhập trùng nhau, khi lọc kết quả khách hàng nó bỏ trùng đi. thể hiện 1 khách hàng thôi thì làm sao ạ. em cảm ơn.

HUONGHCKT · 30/6/22

huyngo19888 đã viết:
Bác giúp e thêm chỗ này với. Ví dụ cột A, B e lỡ nhập trùng nhau, khi lọc kết quả khách hàng nó bỏ trùng đi. thể hiện 1 khách hàng thôi thì làm sao ạ. em cảm ơn.

View attachment 278140

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

snow25 · 1/7/22

HUONGHCKT đã viết:
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 · 1/7/22

snow25 đã viết:
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 · 1/7/22

HUONGHCKT đã viết:
Của bạn đây.
Xem file đính kèm

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

HUONGHCKT · 1/7/22

bebo021999 đã viết:
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.

Mã:

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

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

Mã:

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

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

Mã:

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 · 1/7/22

HUONGHCKT đã viết:
Mã:

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.

PHP:

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 · 1/7/22

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 · 1/7/22

huyngo19888 đã viết:
Bác giúp e thêm chỗ này với. Ví dụ cột A, B e lỡ nhập trùng nhau, khi lọc kết quả khách hàng nó bỏ trùng đi. thể hiện 1 khách hàng thôi thì làm sao ạ. em cả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 · 1/7/22

tranhungdao12a3 đã viết:
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 · 1/7/22

Nhattanktnn đã viết:
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 · 1/7/22

bebo021999 đã viết:
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.

PHP:

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 · 1/7/22

bebo021999 đã viết:
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.

PHP:

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 · 1/7/22

Maika8008 đã viết:
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 · 1/7/22

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

kbw1 · 4/7/22

vanthinh3101 đã viết:
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.

Lọc dữ liệu khách hàng theo mã hàng.

Thành viên mới

File đính kèm

Thành viên gạo cội

Thành viên mới

Zalo 0986997214

File đính kèm

Thành viên mới

Zalo 0986997214

File đính kèm

Thành viên gạo cội

Zalo 0986997214

Thành viên gạo cội

File đính kèm

Zalo 0986997214

Thành viên gạo cội

File đính kèm

Thành viên tiêu biểu

File đính kèm

Thành viên tích cực

File đính kèm

Thành viên gắn bó

Thành viên tiêu biểu

Zalo 0986997214

Thành viên gạo cội

Thành viên gắn bó

Chuyên gia GPE

Thành viên tích cực