Dò tìm trả về nhiều dòng giá trị

[skullrock]

Chào anh em,
Mình xin phép gửi file đính kèm, trong đó có mô tả bài toán mình đang cần giải quyết.
Mình đã kiếm thử trên mạng rồi nhưng ko tìm được giải pháp, mong anh em GPE xem qua giúp mình.
Xin cám ơn.

 

[concogia]

Chào anh em,
Mình xin phép gửi file đính kèm, trong đó có mô tả bài toán mình đang cần giải quyết.
Mình đã kiếm thử trên mạng rồi nhưng ko tìm được giải pháp, mong anh em GPE xem qua giúp mình.
Xin cám ơn.

Theo mình nghĩ, bài này phải dùng VBA "xử" nó chứ công thức chắc "tèo" quá
Thân

 

[skullrock]

Cám ơn bạn, để mình post thêm bên VBA.

 

[thanh_tks]

Chào anh em,
Mình xin phép gửi file đính kèm, trong đó có mô tả bài toán mình đang cần giải quyết.
Mình đã kiếm thử trên mạng rồi nhưng ko tìm được giải pháp, mong anh em GPE xem qua giúp mình.
Xin cám ơn.

Ngộ tính về VBA của mình rất kém nên chỉ có For .. Next thôi
Xem tạm file đính kèm nhé!

Sub LOC()
    Dim data, ma, tam, i, j, k
    Dim d As Object
        Set d = CreateObject("Scripting.Dictionary")
        data = Sheet1.Range("A1:H10")
            ReDim tam(1 To UBound(data), 1 To 8)
            ReDim ma(1 To UBound(data), 1 To 1)
            ma(1, 1) = Sheet1.Range("J18")
                For i = 1 To UBound(data)
                       For j = 1 To UBound(data)
                           For h = 1 To UBound(data)
                                If data(j, 1) = ma(h, 1) Then
                                    If Not d.exists(data(j, 1) & data(j, 5)) Then
                                      k = k + 1
                                      d.Add data(j, 1) & data(j, 5), k
                                           For m = 1 To 8
                                               tam(k, m) = data(j, m)
                                           Next m
                                           ma(k + 1, 1) = data(j, 5)
                                    End If
                                End If
                           Next h
                       Next j
                Next i
            Sheet1.Range("K20").Resize(1000, 8).ClearContents
           If k > 0 Then
            Sheet1.Range("K20").Resize(k, 8) = tam
           End If

End Sub

 

[concogia]

Theo mình nghĩ, bài này dùng bộ lọc sẽ bớt được mấy em "Pho Pho" lồng nhau:

Public Sub ToTe()
    Application.ScreenUpdating = False
    Dim Vung, Tiep, Tach, Dk, I, Cll
        Set Vung = Range([A2], [A2].End(xlDown)).Resize(, 8)
        ReDim Mg(1 To Vung.Rows.Count, 1 To Vung.Columns.Count)
        Dk = [A18]: [A20:H100].Clear
            With Vung
                .AutoFilter 1, Dk
                .SpecialCells(12).Copy [A20]
                    For Each Cll In .Columns(5).Offset(1).SpecialCells(12)
                        If Cll <> "" Then Tiep = Tiep & " " & Cll
                    Next Cll
                .AutoFilter
            End With
                Do While Len(Tiep)
                    Tach = Split(Tiep): Tiep = ""
                    For I = 1 To UBound(Tach)
                        With Vung
                        .AutoFilter 1, Tach(I)
                        .Offset(1).SpecialCells(12).Copy [A2000].End(xlUp)(2)
                        For Each Cll In .Columns(5).Offset(1).SpecialCells(12)
                            If Cll <> "" Then Tiep = Tiep & " " & Cll
                        Next Cll
                        .AutoFilter
                    End With
                    Next I
                Loop
    Application.ScreenUpdating = True
End Sub

 

[VetMini]

1. Bài toán này rất nguy hiểm: lỡ gặp tham chiếu vòng thì chạy đến sang năm chưa xong. Trừ phi bị hết bộ nhớ vì mảng lớn quá.

2. Muốn giảm số vòng lặp thì dùng đệ quy.

 

[skullrock]

Theo mình nghĩ, bài này dùng bộ lọc sẽ bớt được mấy em "Pho Pho" lồng nhau:

Public Sub ToTe()
    Application.ScreenUpdating = False
    Dim Vung, Tiep, Tach, Dk, I, Cll
        Set Vung = Range([A2], [A2].End(xlDown)).Resize(, 8)
        ReDim Mg(1 To Vung.Rows.Count, 1 To Vung.Columns.Count)
        Dk = [A18]: [A20:H100].Clear
            With Vung
                .AutoFilter 1, Dk
                .SpecialCells(12).Copy [A20]
                    For Each Cll In .Columns(5).Offset(1).SpecialCells(12)
                        If Cll <> "" Then Tiep = Tiep & " " & Cll
                    Next Cll
                .AutoFilter
            End With
                Do While Len(Tiep)
                    Tach = Split(Tiep): Tiep = ""
                    For I = 1 To UBound(Tach)
                        With Vung
                        .AutoFilter 1, Tach(I)
                        .Offset(1).SpecialCells(12).Copy [A2000].End(xlUp)(2)
                        For Each Cll In .Columns(5).Offset(1).SpecialCells(12)
                            If Cll <> "" Then Tiep = Tiep & " " & Cll
                        Next Cll
                        .AutoFilter
                    End With
                    Next I
                Loop
    Application.ScreenUpdating = True
End Sub

code này của anh concogia chạy tốt rồi, mình chỉnh lại vùng và số cột thì áp dụng được cho bảng dữ liệu lớn hơn nữa.
Cám ơn anh em nhiều.
Tiện thể cho em hỏi thêm thông số 12 trong .SpecialCells(12) có nghĩa gì vậy anh, em mới bik thông số này.