Nhờ giúp đỡ code nhóm dữ liệu theo điều kiện

[Alber]

Xin chào anh/chị
Do máy công ty đang dùng office 2010 không dùng được hàm mới, nên nhờ anh/chị giúp dùm code nối dữ liệu khi trùng mã STT.
kết quả mong muốn như phía dưới, xin chan thành cảm ơn anh/chị.

 

[Hoàng Tuấn 868]

Xin chào anh/chị
Do máy công ty đang dùng office 2010 không dùng được hàm mới, nên nhờ anh/chị giúp dùm code nối dữ liệu khi trùng mã STT.
kết quả mong muốn như phía dưới, xin chan thành cảm ơn anh/chị.
View attachment 285200

Bạn chịu khó tìm trên diễn đàn, loại này có khá nhiều đó.

 

[Alber]

Bạn chịu khó tìm trên diễn đàn, loại này có khá nhiều đó.

Bài đã được tự động gộp: 28/12/22

Bạn chịu khó tìm trên diễn đàn, loại này có khá nhiều đó.

Em chưa biết từ khoá là gì
Anh cho em từ khoá nhé, để e seach

 

[Hoàng Tuấn 868]

Anh cho em từ khoá nhé

Từ khóa như tiêu đề trừ câu nhờ giúp đỡ.

 

[Alber]

Từ khóa như tiêu đề trừ câu nhờ giúp đỡ.

Em cám ơn anh
Để e tìm xem sao

 

[VetMini]

...
Do máy công ty đang dùng office 2010 không dùng được hàm mới, ...

Công ty này không biết mắc cở.
Đồi hỏi việc rắc rối mà không chịu bỏ tiền mua phần mềm. Để cho nhân viên đi nhờ người ngoài làm giùm.

 

[Alber]

Anh có thể giúp e dc ko ạ

 

[Hoàng Tuấn 868]

Công ty này không biết mắc cở.
Đồi hỏi việc rắc rối mà không chịu bỏ tiền mua phần mềm. Để cho nhân viên đi nhờ người ngoài làm giùm.

Quá chuẩn rồi anh ơi.

 

[Alber]

Quá chuẩn rồi anh ơi.
View attachment 285203

Em seach nảy giờ vẫn chưa có kết quả
A biết link ko chỉ em với

 

[SA_DQ]

Anh có thể giúp e dc ko ạ

Function MaKH(SoTT As String, CSDL As Range)
 Const FC As String = "\\"
 Dim J As Long, Rws As Integer
 
 Rws = CSDL.Rows.Count
 For J = 1 To Rws + 3
    If Cells(J, 1).Value = SoTT Then
        MaKH = Cells(J, 3).Value & FC & MaKH
    End If
 Next J
 MaKH = Left(MaKH, Len(MaKH) - 2)
End Function

 

[Alber]

Function MaKH(SoTT As String, CSDL As Range)
 Const FC As String = "\\"
 Dim J As Long, Rws As Integer
 
 Rws = CSDL.Rows.Count
 For J = 1 To Rws + 3
    If Cells(J, 1).Value = SoTT Then
        MaKH = Cells(J, 3).Value & FC & MaKH
    End If
 Next J
 MaKH = Left(MaKH, Len(MaKH) - 2)
End Function

Em cám ơn anh nhiều ạ!

 

[Ronaldinho7]

Xin chào anh/chị
Do máy công ty đang dùng office 2010 không dùng được hàm mới, nên nhờ anh/chị giúp dùm code nối dữ liệu khi trùng mã STT.
kết quả mong muốn như phía dưới, xin chan thành cảm ơn anh/chị.
View attachment 285200

Bạn sử dụng code sau và kiểm tra lại kết quả nhé!

Sub Gop_DL()
    Dim Lr&, i&, Arr(), Res(1 To 10000, 1 To 3)
    Dim Dic As Object, Key$, k&
    Set Dic = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    With Sheets("Sheet1")
        .Range("H4:J10000").ClearContents
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        Arr = .Range("A4:C" & Lr).Value
        For i = 1 To UBound(Arr)
            Key = Arr(i, 1)
            If Not Dic.exists(Key) Then
                k = k + 1
                Dic.Add (Key), k
                Res(k, 1) = Arr(i, 1)
                Res(k, 2) = Arr(i, 2)
                Res(k, 3) = Arr(i, 3)
            Else
                Res(Dic.Item(Key), 3) = Res(Dic.Item(Key), 3) & "//" & Arr(i, 3)
            End If
        Next i
        .Range("H4").Resize(k, 3).Value = Res
    End With
    Set Dic = Nothing
End Sub

 

[Alber]

Bạn sử dụng code sau và kiểm tra lại kết quả nhé!

Sub Gop_DL()
    Dim Lr&, i&, Arr(), Res(1 To 10000, 1 To 3)
    Dim Dic As Object, Key$, k&
    Set Dic = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    With Sheets("Sheet1")
        .Range("H4:J10000").ClearContents
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        Arr = .Range("A4:C" & Lr).Value
        For i = 1 To UBound(Arr)
            Key = Arr(i, 1)
            If Not Dic.exists(Key) Then
                k = k + 1
                Dic.Add (Key), k
                Res(k, 1) = Arr(i, 1)
                Res(k, 2) = Arr(i, 2)
                Res(k, 3) = Arr(i, 3)
            Else
                Res(Dic.Item(Key), 3) = Res(Dic.Item(Key), 3) & "//" & Arr(i, 3)
            End If
        Next i
        .Range("H4").Resize(k, 3).Value = Res
    End With
    Set Dic = Nothing
End Sub

Dạ, e cảm ơn anh nhiều ạ!