Cần tìm nhiều text của sheet chi tiet (1 người xem)

[hienxh_1979]

Mình có 1 file cần nhờ các bạn giúp, Cột 2 của sheet Chi tiêt có 1 người có thể đạt được có rất nhiều ĐDT của Cột 8, để trả kết quả cột 14 của sheet TH DS (xem file đính kèm), ví dụ như:
1. Nguyễn Văn A: ĐDT-1, ĐDT-3, ĐDT-6, ĐDT-11 (cột 14 của TH DS)
2. B: ĐDT-2, ĐDT-7 (cột 14 của TH DS)
3....
Mình không biết tìm thế nào cho ra kết quả như vậy.
Nhờ các bạn giúp mình. Cảm ơn rất nhiều.

 

[befaint]

trả kết quả

Hàm TextJoin,
Hoặc:

Sub Vidu()
    Dim a, b, i, j, r, m1, m2, name
    Dim res(), sKQ()
    a = Sheet1.Range("B6:H283").Value   ''<--- Vung du lieu chi tiet: B6:H283
    b = Sheet2.Range("B7:B247").Value   ''<--- Vung du lieu TH: B7:B247
    m1 = UBound(a, 1)
    m2 = UBound(b, 1)
    ReDim res(1 To m2, 1 To 1)
    For r = 1 To m2
        name = b(r, 1)
        If name <> "" Then
            ReDim sKQ(1 To m1): j = 0
            For i = 1 To m1
                If name Like a(i, 1) Then
                    j = j + 1
                    sKQ(j) = a(i, 7)
                End If
            Next i
            ReDim Preserve sKQ(1 To j)
            res(r, 1) = Join(sKQ, ", ")
        End If
    Next r
    Sheet2.Range("N7").Resize(m2, 1) = res
End Sub

 

[VetMini]

For r = 1 To m2
...
For i = 1 To m1
If name Like a(i, 1) Then
j = j + 1
sKQ(j) = a(i, 7)
End If
Next i
...
Next r

Bạn có m2 lượt. Lượt nào thì bạn cũng dò bao nhiêu đó thôi. Vậy thì cho chúng vào 1 cái đít, dò cho lẹ.

Like của bạn không có wildcard gì hết.

 

[hienxh_1979]

Hàm TextJoin,
Hoặc:

Sub Vidu()
    Dim a, b, i, j, r, m1, m2, name
    Dim res(), sKQ()
    a = Sheet1.Range("B6:H283").Value   ''<--- Vung du lieu chi tiet: B6:H283
    b = Sheet2.Range("B7:B247").Value   ''<--- Vung du lieu TH: B7:B247
    m1 = UBound(a, 1)
    m2 = UBound(a, 2)
    ReDim res(1 To m2, 1 To 1)
    For r = 1 To m2
        name = b(r, 1)
        If name <> "" Then
            ReDim sKQ(1 To m1): j = 0
            For i = 1 To m1
                If name Like a(i, 1) Then
                    j = j + 1
                    sKQ(j) = a(i, 7)
                End If
            Next i
            ReDim Preserve sKQ(1 To j)
            res(r, 1) = Join(sKQ, ", ")
        End If
    Next r
    Sheet2.Range("N7").Resize(m2, 1) = res
End Sub

Mình chưa làm bao giờ, bạn có thể hướng dẫn mình được. Cảm ơn bạn nhiều

 

[befaint]

@ Chủ thớt: Đọc 2 bài đầu tiên.

--------------------
Thử với Dictionary

Option Explicit

Sub vidu2()
    ''Thu voi Dictionary
    Dim a, b, i As Long, m1 As Long, m2 As Long
    Dim res(), sKey As String
    a = Sheet1.Range("B6:H283").Value   ''<--- Vung du lieu chi tiet: B6:H283
    b = Sheet2.Range("B7:B247").Value   ''<--- Vung du lieu TH: B7:B247
    m1 = UBound(a, 1)
    m2 = UBound(b, 1)
    ReDim res(1 To m2, 1 To 1)
    Dim Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To m1
        sKey = a(i, 1)
        If Len(sKey) > 0 Then
            If Dic.exists(sKey) = False Then
                Dic.Add sKey, a(i, 7)
            Else
                Dic.Item(sKey) = Dic.Item(sKey) & ", " & a(i, 7)
            End If
        End If
    Next i
    For i = 1 To m2
        sKey = b(i, 1)
        If Len(sKey) > 0 Then
            If Dic.exists(b(i, 1)) = True Then
                res(i, 1) = Dic.Item(sKey)
            End If
        End If
    Next i
    Sheet2.Range("N7").Resize(m2, 1) = res
End Sub

 

[Hoang2013]

Thử thêm với hàm người dùng:

Function KQua(Ten As String, CSDL As Range) As String
 Dim Arr(), J As Long
 Arr() = CSDL.Value
 For J = 1 To UBound(Arr())
    If Ten = Arr(J, 1) Then
        KQua = Arr(J, 7) & "; " & KQua
    End If
 Next J
End Function

Chú thích: CSDL là vùng "B6:H290" của trang 'CTiet' đã được gán tên.

Chúc xuân vui vẻ.