Public Sub GPE_2()
Dim Dic As Object, sArr(), dArr(), tArr(), I As Long, K As Long, Rws As Long, Col As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Data")
    sArr = .Range("C3", .Range("D65536").End(xlUp)).Resize(, 18).Value
End With
ReDim dArr(1 To UBound(sArr), 1 To 22)
With Sheets("TongHop")
    tArr = .Range("A4:V4").Value
    For I = 5 To UBound(tArr, 2)
        If tArr(1, I) <> Empty Then Dic.Item(tArr(1, I)) = I
    Next I
    For I = 1 To UBound(sArr)
        If sArr(I, 1) <> Empty Then
        Tem = sArr(I, 1)
        If Not Dic.Exists(Tem) Then
            K = K + 1
            Dic.Add Tem, K
            dArr(K, 1) = K: dArr(K, 2) = sArr(I, 1)
            dArr(K, 3) = sArr(I, 2): dArr(K, 4) = sArr(K, 3)
        End If
        If Dic.Exists(sArr(I, 4)) Then
            Col = Dic.Item(sArr(I, 4))
            Rws = Dic.Item(Tem)
            dArr(Rws, Col) = dArr(Rws, Col) + sArr(I, 17)
            If Len(dArr(Rws, Col + 1)) Then
                dArr(Rws, Col + 1) = dArr(Rws, Col + 1) & ", " & sArr(I, 18)
            Else
                dArr(Rws, Col + 1) = sArr(I, 18)
            End If
        End If
        End If
    Next I
    .Range("A6:V1000").ClearContents
    .Range("A6").Resize(K, 22) = dArr
    '.Range("B6").Resize(K, 21).Sort Key1:=.Range("B6")'
End With
Set Dic = Nothing
End Sub