Sub Dic()
Dim sarr, arr(1 To 65000, 1 To 10), i, j, k
Dim Ws As Worksheet, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
For Each Ws In Worksheets
If Ws.Name = "VUON" Or Ws.Name = "KDT" Then
sarr = Ws.Range("B6", Ws.[B65000].End(xlUp)).Resize(, 6).Value2
For i = 1 To UBound(sarr, 1)
If Not Dic.exists(sarr(i, 1)) Then
k = k + 1
Dic.Add sarr(i, 1), k
arr(k, 1) = sarr(i, 1)
If Ws.Name = "VUON" Then
arr(k, 2) = sarr(i, 2)
arr(k, 3) = sarr(i, 3)
Else
arr(k, 5) = sarr(i, 2)
arr(k, 6) = sarr(i, 3)
End If
Else
If Ws.Name = "VUON" Then
arr(Dic.Item(sarr(i, 1)), 2) = arr(Dic.Item(sarr(i, 1)), 2) + sarr(i, 2)
arr(Dic.Item(sarr(i, 1)), 3) = arr(Dic.Item(sarr(i, 1)), 3) + sarr(i, 3)
Else
arr(Dic.Item(sarr(i, 1)), 5) = arr(Dic.Item(sarr(i, 1)), 5) + sarr(i, 2)
arr(Dic.Item(sarr(i, 1)), 6) = arr(Dic.Item(sarr(i, 1)), 6) + sarr(i, 3)
End If
End If
Next i
End If
Next Ws
With Sheets("HUE")
If k Then
.[A8:j65000].ClearContents
.[A8].Resize(k, 10).Value = arr
End If
End With
End Sub