寻求VBA代码帮助，B列有一致排序，A列按字典值大小排序

Sub 合计并排序()
Dim d
Dim i As Integer
Dim j As Integer
Dim a As Integer
Dim b As Integer
Dim rng As Range


Dim arr
Set d = CreateObject("scripting.dictionary")
a = Cells(Rows.Count, 1).End(3).Row
Range(Cells(1, 1), Cells(a, 2)).Select
With ActiveSheet.Sort
With .SortFields
.Clear
.Add Key:=Range("B1"), Order:=xlAscending
End With
With .SortFields
.Clear
.Add Key:=Range("A1"), Order:=xlAscending
End With
.Header = xlGuess
.MatchCase = False
.SortMethod = xlPinYin
.Orientation = xlSortColumns
.SetRange rng:=Selection
.Apply
End With
arr = Range(Cells(1, 1), Cells(a, 2))
For i = 1 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
Next
Sheets("3").Range("a1").Resize(d.Count) = Application.Transpose(d.keys)
Sheets("3").Range("b1").Resize(d.Count) = Application.Transpose(d.items)
b = Sheets("3").Cells(Rows.Count, 1).End(3).Row
For i = b To 1 Step -1
For j = 2 * a To 1 Step -1
If Cells(j, 1) = Sheets("3").Cells(i, 1) Then
Rows(j + 1).Insert
Cells(j + 1, 1) = Cells(j, 1) & "合计"
Cells(j + 1, 2) = Sheets("3").Cells(i, 2)
Exit For
End If
Next
Nex
End Sub