Xin hướng dẫn cách ghép nội dung các ô có cùng điều kiện

[thuhien.st]

Em chào các anh chị trong diễn đàn, mong mọi người giúp đỡ em trường hợp này ạ. Em gửi bảng excel đính kèm ạ. Trong bảng em có cột số chứng từ, cột diễn giải. Có chứng từ chỉ có 1 nội dung diễn giải, nhưng có những chứng từ có 2,3, 4 nội dung diễn giải. Vậy anh/chị chỉ cho em cách ghép nội dung của các ô diễn giải lại với nhau với điều kiện có cùng số chứng từ và kết quả trả về trong cột nội dung ạ. Em xin cảm ơn ạ.

 

[bebo021999]

Nhấn vào nút RUN nhé.

Option Explicit
Sub Ghep()
Dim lr&, i&, j&, dg As String, dg2 As String, dic As Object, arr(), st As String, rng, key
Set dic = CreateObject("Scripting.dictionary")
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("C2:D" & lr).Value
ReDim arr(1 To lr - 1, 1 To 1)
    For i = 1 To lr - 1
        If Not dic.exists(rng(i, 1)) Then
            dg = rng(i, 2)
            dic(rng(i, 1)) = dg
        Else
            For j = 1 To Len(dg)
                If Mid(dg, 1, j) = Mid(rng(i, 2), 1, j) Then
                Else
                    dg2 = dg & ", " & Mid(rng(i, 2), j)
                    Exit For
                End If
            Next
            dic(rng(i, 1)) = dg2
        End If
    Next
    For i = 1 To lr - 1
        For Each key In dic.keys
            If rng(i, 1) = key Then arr(i, 1) = dic(key)
        Next
    Next
    Range("E2").Resize(lr - 1, 1) = arr
End Sub

 

[thuhien.st]

Nhấn vào nút RUN nhé.

Option Explicit
Sub Ghep()
Dim lr&, i&, j&, dg As String, dg2 As String, dic As Object, arr(), st As String, rng, key
Set dic = CreateObject("Scripting.dictionary")
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("C2:D" & lr).Value
ReDim arr(1 To lr - 1, 1 To 1)
    For i = 1 To lr - 1
        If Not dic.exists(rng(i, 1)) Then
            dg = rng(i, 2)
            dic(rng(i, 1)) = dg
        Else
            For j = 1 To Len(dg)
                If Mid(dg, 1, j) = Mid(rng(i, 2), 1, j) Then
                Else
                    dg2 = dg & ", " & Mid(rng(i, 2), j)
                    Exit For
                End If
            Next
            dic(rng(i, 1)) = dg2
        End If
    Next
    For i = 1 To lr - 1
        For Each key In dic.keys
            If rng(i, 1) = key Then arr(i, 1) = dic(key)
        Next
    Next
    Range("E2").Resize(lr - 1, 1) = arr
End Sub

Em cảm ơn anh ạ!