Tham chiếu bảng dữ liệu trả về mảng kết quả

[PHUNGUYENHAO]

Bạn đổi tên các sheet có dấu thành không dấu nhé.
Mình đổi tên thành task1 và task2
Tại thêm 2 sheet trống ketqua1 và ketqua2 để lưu kết quả

Option Explicit
Sub task1()
Dim lr1&, lr2&, i&, j&, k&, rng, arr(1 To 100000, 1 To 6)
Dim ghichu As Range, s, c As Boolean, gc As String
With Sheets("Task1")
    lr1 = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A3:E" & lr1).Value
    lr2 = .Cells(Rows.Count, "H").End(xlUp).Row
    Set ghichu = .Range("H3:H" & lr2)
End With
For i = 1 To UBound(rng)
    c = False: gc = "": s = Split(";" & rng(i, 5), ";")
    For j = 1 To UBound(s)
        If WorksheetFunction.CountIf(ghichu, s(j)) Then
            c = True
            gc = IIf(gc = "", s(j), gc & ";" & s(j))
        End If
    Next
    If c Then
        k = k + 1: arr(k, 6) = gc
        For j = 1 To 5
            arr(k, j) = rng(i, j)
        Next
    End If
Next
With Sheets("ketqua1")
    .Range("A2:E2").Value = Sheets("Task1").Range("A2:E2").Value
    .Range("A3:F100000").ClearContents
    If k > 0 Then .Range("A3").Resize(k, 6).Value = arr
End With
End Sub

Sub task2()
Dim lr1&, lr2&, i&, j&, c&, k&, t&, m&, rng, arr(1 To 100000, 1 To 8)
Dim tc As Range, cell As Range
With Sheets("Task2")
    lr1 = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A3:F" & lr1).Value
    lr2 = .Cells(Rows.Count, "I").End(xlUp).Row
    Set tc = .Range("I3:I" & lr2)
End With
For i = 1 To UBound(rng)
    c = WorksheetFunction.CountIf(tc, rng(i, 6))
    If c > 0 Then
        k = k + 1: t = 0
        For j = 1 To 6
            arr(k, j) = rng(i, j)
        Next
        For Each cell In tc
            If cell.Value = rng(i, 6) Then
                k = k + 1: t = t + 1: m = m + 1
                arr(k, 1) = m: arr(k, 2) = rng(i, 1): arr(k, 3) = rng(i, 3)
                arr(k, 4) = rng(i, 4): arr(k, 5) = rng(i, 5): arr(k, 6) = rng(i, 6)
                arr(k, 7) = cell.Offset(, 1).Value: arr(k, 8) = cell.Offset(, 2).Value
            End If
        Next
    End If
Next
With Sheets("ketqua2")
    .Range("A2:F2").Value = Sheets("Task1").Range("A2:F2").Value
    .Range("G2:H2").Value = Array("Ten_nhom", "vi_tri")
    .Range("A3:H100000").NumberFormat = "@"
    .Range("A3:H100000").ClearContents
    If k > 0 Then .Range("A3").Resize(k, 8).Value = arr
End With
End Sub

Mình có file này nó phát sinh thêm một điều kiện từ yêu cầu task1 bạn xem dùm mình nhe. Cảm ơn nhiều nhiều!!