Attribute VB_Name = "工作表14"
Private Sub Worksheet_Activate()
    Dim startTime As Double, totalRows As Long
    Dim dict As Object
    Dim itemAddup As New stdArray
    Dim changeRange As Variant
    Dim tmp As stdArray
    Dim oArr As Variant, pArr As Variant, qArr As Variant
    Dim i As Long, arrWords As Variant
    Dim key As Variant, vIter As Variant
    
    ' 創建字典
    Set dict = CreateObject("Scripting.Dictionary")

    ' 設置範圍
    changeRange = Me.Range("ChangeTBL").Resize(100)
    
    ' 開始計時
    startTime = Timer
    
    ' 填充字典
    For i = 1 To UBound(changeRange)
        If Not IsEmpty(changeRange(i, 1)) Then
            Call FillDictionary(dict, changeRange(i, 1) & "_" & changeRange(i, 2), changeRange(i, 3))
        End If
    Next i
    
    ' 將字典中的項目添加到 itemAddup
    Set itemAddup = stdArray.Create
    For Each key In dict.keys
        itemAddup.Push key & "_" & dict(key)
    Next key
    totalRows = dict.count
    
    ' 初始化輸出範圍的數組
    Me.Range("O3").CurrentRegion.ClearContents
    oArr = Me.Range("O3").Resize(totalRows)
    pArr = Me.Range("P3").Resize(totalRows)
    qArr = Me.Range("Q3").Resize(totalRows)
    
    ' 排序並將值填充到臨時數組
    Set tmp = stdArray.Create
    itemAddup.Sort().ForEach stdLambda.Create("$1.push($2)").Bind(tmp)
    
    ' 迭代臨時數組並將值填充到相應的欄位
    i = 1
    For Each vIter In tmp
        arrWords = Split(vIter, "_")
        oArr(i, 1) = arrWords(0)
        pArr(i, 1) = arrWords(1)
        qArr(i, 1) = arrWords(2)
        i = i + 1
    Next vIter
    
    ' 顯示執行時間
    Me.Range("O1").value = Timer - startTime

    ' 將結果寫回工作表
    Me.Range("O3").Resize(totalRows).value = oArr
    Me.Range("P3").Resize(totalRows).value = pArr
    Me.Range("Q3").Resize(totalRows).value = qArr
End Sub

Private Sub FillDictionary(ByRef dict As Object, item As Variant, itemValue As Variant)
    If dict.Exists(item) Then
        dict(item) = dict(item) + itemValue
    Else
        dict.Add item, itemValue
    End If
End Sub