Sub Main()
Dim Dic As Object
Dim aSrc, aDes
Dim tmp1 As String, tmp2 As String, lQty As Long, tmp3 As String
Dim str1 As String, str2 As String, str3 As String, str4 As String, str5 As String
Dim lR As Long, lC As Long, n As Long
ReDim arr(1 To 6, 1 To 1)
str1 = "G" & ChrW(7840) & "O"
str2 = "CAO SU"
str3 = "H" & ChrW(7840) & "T TIÊU"
str4 = "H" & ChrW(7840) & "T " & ChrW(272) & "I" & ChrW(7872) & "U"
str5 = "CÀ PHÊ"
arr(2, 1) = str1: arr(3, 1) = str2: arr(4, 1) = str3: arr(5, 1) = str4: arr(6, 1) = str5
n = 1
Set Dic = CreateObject("Scripting.Dictionary")
aSrc = Sheet1.Range("A9:D10000")
For lR = 1 To UBound(aSrc, 1)
tmp1 = Trim(CStr(aSrc(lR, 1)))
tmp2 = Trim(CStr(aSrc(lR, 2)))
tmp3 = Trim(CStr(aSrc(lR, 4)))
If Val(aSrc(lR, 3)) > 0 Then lQty = CLng(Replace(aSrc(lR, 3), ".", ""))
If Len(tmp2) = 0 Then
If Len(tmp1) And Len(tmp3) Then
If Not Dic.Exists(tmp1) Then
n = n + 1
ReDim Preserve arr(1 To 6, 1 To n)
arr(1, n) = tmp1
Dic.Add tmp1, n
End If
End If
End If
Select Case UCase(tmp1)
Case Is = str1: arr(2, n) = arr(2, n) + lQty
Case Is = str2: arr(3, n) = arr(3, n) + lQty
Case Is = str3: arr(4, n) = arr(4, n) + lQty
Case Is = str4: arr(5, n) = arr(5, n) + lQty
Case Is = str5: arr(6, n) = arr(6, n) + lQty
End Select
Next
aDes = Transpose2DArray(arr)
Range("I3").Resize(n, 6).Value = aDes
End Sub
Private Function Transpose2DArray(ByVal TableArray)
Dim lR As Long, lC As Long
Dim arr, aTemp
On Error Resume Next
aTemp = TableArray
ReDim arr(LBound(aTemp, 2) To UBound(aTemp, 2), LBound(aTemp, 1) To UBound(aTemp, 1))
For lR = LBound(aTemp, 1) To UBound(aTemp, 1)
For lC = LBound(aTemp, 2) To UBound(aTemp, 2)
arr(lC, lR) = aTemp(lR, lC)
Next
Next
Transpose2DArray = arr
End Function
ko hiểu gì hết.
