你的数组brr定义得太小啦!
Sub aa()
Dim i%, j%, k%, n%, x%, y%, arr, brr(1 To 10000, 1 To 2000), d1 As Object, d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr = Range("A2:B" & Range("A" & Rows.Count).End(3).Row)
x = 1: y = 1
For i = 1 To UBound(arr)
If Not d1.Exists(arr(i, 2)) Then
x = x + 1
d1(arr(i, 2)) = x
brr(x, 1) = arr(i, 2)
End If
If Not d2.Exists(arr(i, 1)) Then
y = y + 1
d2(arr(i, 1)) = y
brr(1, y) = arr(i, 1)
End If
brr(d1(arr(i, 2)), d2(arr(i, 1))) = brr(d1(arr(i, 2)), d2(arr(i, 1))) + 1
Next
Dim crr()
ReDim crr(1 To x - 1, 1 To 7)
For i = 2 To x
crr(i - 1, 1) = brr(i, 1)
For j = 2 To y
For k = 1 To 3
If brr(i, j) > crr(i - 1, k + 4) Then
For n = 3 To k + 1 Step -1
crr(i - 1, n + 1) = crr(i - 1, n)
crr(i - 1, n + 4) = crr(i - 1, n + 3)
Next
crr(i - 1, k + 1) = brr(1, j)
crr(i - 1, k + 4) = brr(i, j)
Exit For
End If
Next
Next
Next
[G7].Resize(1, 4) = Array("CODE", "DEVICES里出现次数最多", "出现次数第二多", "出现次数第三多")
[G8].Resize(x - 1, 4) = crr
End Sub