Option Explicit
Sub GPE()
Dim DicNgay As Object: Set DicNgay = CreateObject("Scripting.Dictionary")
Dim DicVLieu As Object: Set DicVLieu = CreateObject("Scripting.Dictionary")
'Dim DicNgay As Scripting.Dictionary: Set DicNgay = New Scripting.Dictionary
'Dim DicVLieu As Scripting.Dictionary: Set DicVLieu = New Scripting.Dictionary
Dim VLieu As String
Dim Ngay As Long, i As Long
Dim Arr As Variant, ArrNgay As Variant, ArrVLieu As Variant, ArrKQ As Variant
Dim WsT As Worksheet
On Error Resume Next 'neu chua co sheet tam thi tao
If CBool(Len(ThisWorkbook.Sheets("KQ").Name) = 0) Then
Set WsT = ThisWorkbook.Sheets.Add ' After:=ActiveSheet
WsT.Name = "KQ"
Else 'nguoc lai co roi thi set
Set WsT = ThisWorkbook.Sheets("KQ")
End If
With Sheets("VATTU")
Arr = .Range("B2").Resize( _
.Cells(.Rows.Count, "A").End(xlUp).Row, _
.Cells(1, .Columns.Count).End(xlToLeft).Column).Value2
End With
For i = LBound(Arr, 1) To UBound(Arr, 1)
If Not DicNgay.Exists(Arr(i, 1)) And Len(Arr(i, 1)) > 0 Then DicNgay.Add Arr(i, 1), i
If Not DicVLieu.Exists(Arr(i, 2)) And Len(Arr(i, 2)) > 0 Then DicVLieu.Add Arr(i, 2), i
If Len(Arr(i, 1)) > 0 Then Ngay = CLng(Arr(i, 1)) Else Arr(i, 1) = Ngay
Next i
ReDim ArrNgay(0 To DicNgay.Count - 1)
ReDim ArrVLieu(0 To DicVLieu.Count - 1)
For i = 0 To UBound(ArrNgay)
ArrNgay(i) = DicNgay.Keys()(i)
Next i
ArrNgay = Sort1DArray(ArrNgay, False, False)
For i = 0 To UBound(ArrVLieu)
ArrVLieu(i) = DicVLieu.Keys()(i)
Next i
ArrVLieu = Sort1DArray(ArrVLieu, True, False)
Set DicNgay = Nothing
Set DicVLieu = Nothing
Set DicNgay = CreateObject("Scripting.Dictionary")
Set DicVLieu = CreateObject("Scripting.Dictionary")
'Set DicNgay = New Scripting.Dictionary
'Set DicVLieu = New Scripting.Dictionary
For i = 0 To UBound(ArrNgay)
DicNgay.Add CLng(ArrNgay(i)), 8 + i
Next i
For i = 0 To UBound(ArrVLieu)
DicVLieu.Add ArrVLieu(i), 2 + i
Next i
ReDim ArrKQ(1 To UBound(ArrVLieu, 1) + 2, 1 To UBound(ArrNgay, 1) + 8)
ArrKQ(1, 1) = "Stt"
ArrKQ(1, 2) = "Tên"
ArrKQ(1, 3) = "m" & ChrW(227) & " VT"
ArrKQ(1, 4) = ChrW(272) & ChrW(417) & "n v" & ChrW(7883)
ArrKQ(1, 5) = "S" & ChrW(7889) & " l" & ChrW(432) & ChrW(7907) & "ng"
ArrKQ(1, 6) = ChrW(272) & ChrW(417) & "n gi" & ChrW(225)
ArrKQ(1, 7) = "Th" & ChrW(224) & "nh ti" & ChrW(7873) & "n"
For i = LBound(ArrVLieu, 1) To UBound(ArrVLieu, 1)
ArrKQ(2 + i, 1) = i + 1 'dien STT
ArrKQ(2 + i, 2) = ArrVLieu(i) 'dien ten vat lieu
Next i
For i = LBound(ArrNgay, 1) To UBound(ArrNgay, 1)
ArrKQ(1, 8 + i) = ArrNgay(i) 'dien ngay
Next i
For i = LBound(Arr, 1) To UBound(Arr, 1)
ArrKQ(DicVLieu.Item(Arr(i, 2)), 5) = "=sum(" & Cells(DicVLieu.Item(Arr(i, 2)), 8).Resize(1, DicNgay.Count).Address(0, 0) & ")"
ArrKQ(DicVLieu.Item(Arr(i, 2)), 7) = "=" & Cells(DicVLieu.Item(Arr(i, 2)), 5).Address(0, 0) & "*" & Cells(DicVLieu.Item(Arr(i, 2)), 6).Address(0, 0)
ArrKQ(DicVLieu.Item(Arr(i, 2)), 4) = Arr(i, 4) 'dien don vi
ArrKQ(DicVLieu.Item(Arr(i, 2)), DicNgay.Item(Arr(i, 1))) = _
ArrKQ(DicVLieu.Item(Arr(i, 2)), DicNgay.Item(Arr(i, 1))) + Arr(i, 5) 'dien so luong
Next i
WsT.Cells.ClearContents
WsT.Cells(1, 1).Resize(UBound(ArrKQ, 1), UBound(ArrKQ, 2)) = ArrKQ
Set DicNgay = Nothing
Set DicVLieu = Nothing
End Sub
Function Sort1DArray(ByVal Arr, Optional ByVal isText As Boolean = False, Optional ByVal isDESC As Boolean = False)
Dim sCommand As String
sCommand = "('" & Join(Arr, vbBack) & "').split('" & vbBack & "').sort("
If isText Then
sCommand = sCommand & ")"
Else
sCommand = sCommand & "function(a,b){return (a-b)})"
End If
If isDESC Then sCommand = sCommand & ".reverse()"
sCommand = sCommand & ".join('" & vbBack & "')"
With CreateObject("MSScriptControl.ScriptControl")
.Language = "JavaScript"
Sort1DArray = Split(.Eval(sCommand), vbBack)
End With
End Function
