Sub main()
Set dic = CreateObject("scripting.dictionary") '定義詞典
arr = Range("A1:C500") '假設最大行數為500，將A1至C500區域放入數組
For i = 1 To UBound(arr) '從1到數組最大行數循環
If arr(i, 1) <> "" And arr(i, 1) <> "裝置" Then '提出空格和標題行
dic(arr(i, 1)) = dic(arr(i, 1)) + arr(i, 3) '用字典去除重復，並且進行數量累加
End If
Next i
[e2].Resize(dic.Count, 1) = Application.Transpose(dic.keys) '將字典的keys(即A列不重復的值)轉置並放在E列
[f2].Resize(dic.Count, 1) = Application.Transpose(dic.items) '將字典的kItems（即累加結果)轉置並放在E列
End Sub