Xin Cảm ơn , Các Anh. Thật ra em cũng đã có nghĩ ra cách này nhưng mà nó dài dòng quá .
code mình như bên dưới
Sub Get_Du_Lieu()
Dim WK As Worksheet
Dim I As Integer, eR As Integer, K As Integer, J As Integer
Dim sArr(), rArr(), Tmp As String, tArr()
Dim Dic As Object, Rng(), Y As String, Y1 As String
Dim R As Integer, N As Integer, Col As Integer
Set WK = Worksheets("Test")
Set Dic = CreateObject("Scripting.Dictionary")
'------------------------------------------------------------
eR = WK.Range("A10000").End(xlUp).Row
sArr = WK.Range("A2:C" & eR).Value
ReDim rArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 1))
'------------------------------------------------------------
'---------- Lấy Tên ------------
WK.Range("F2:M10000").ClearContents
For I = 1 To UBound(sArr, 1)
If Not IsEmpty(sArr(I, 1)) Then
Tmp = sArr(I, 1)
If Not Dic.exists(Tmp) Then
K = K + 1
Dic.Add Tmp, K
rArr(K, 1) = sArr(I, 1)
End If
End If
Next I
Range("F2").Resize(K, 1) = rArr
'---------- Lấy Loại ----------------
K = 0
For I = 2 To UBound(sArr, 1)
If Not IsEmpty(sArr(I, 2)) Then
Tmp = sArr(I, 2)
If Not Dic.exists(Tmp) Then
K = K + 1
Dic.Add Tmp, K
rArr(K, 1) = sArr(I, 2)
End If
End If
Next I
Range("g2").Resize(1, K) = WorksheetFunction.Transpose(rArr)
'-------------------------------------------------------------------
'------------ Lấy Số Lượng -----------------
Rng = WK.Range("A3:C" & eR).Value
For R = 1 To UBound(Rng)
Y = Rng(R, 1) & Rng(R, 2)
Dic(Y) = Dic(Y) + Rng(R, 3)
Next R
N = WK.Range("F1000").End(xlUp).Row
Col = Cells(2, WK.Columns.Count).End(xlToLeft).Column 'CurrentRegion.Columns.Count '
tArr = Range(Cells(1, 6), Cells(N, Col))
For I = 3 To N
For J = 2 To Col - 5
Y1 = tArr(I, 1) & tArr(2, J)
tArr(I, J) = Dic(Y1)
Next J
Next I
Range(Cells(1, 6), Cells(N, Col)) = tArr
Set Dic = Nothing
End Sub
