excelpx网的6段VBA题。

Sub t1()
Dim t
t = Timer
Dim arr, lrow&, arr1, z%, i&, x%, y%, r%, arr2, rr%, zz%, d As Object, arr3
Set d = CreateObject("Scripting.Dictionary")
lrow = [c10000].End(3).Row
arr = Range("a2:c" & lrow)
ReDim arr1(1 To lrow) As Integer
ReDim arr2(1 To lrow - 1, 1 To 1) As Integer
For i = 1 To lrow - 1
If arr(i, 1) <> "" Then
z = z + 1
End If
arr1(i) = z
Next
arr1(lrow) = z + 1
z = 0
For i = 1 To arr1(lrow - 1)
y = z + 1
Do While i = arr1(z + 1)
z = z + 1
Loop
For r = y To z
d(arr(r, 3)) = ""
Next
arr3 = d.keys
For r = y To z
zz = 1
For rr = 0 To UBound(arr3)
If arr(r, 3) < arr3(rr) Then
zz = zz + 1
End If
Next
arr2(r, 1) = zz
Next
d.RemoveAll
Next
Range("d2:d" & lrow) = arr2
Range("g16") = Timer - t
End Sub
刚好卡在那秒数上，我也没办法啊，哭。

@xzk235
将字典赋值给数组然后循环会稍微快一点，按你的模块3改了改，（主要就是把字典赋值给数组）不过还是没达到要求。
Sub paiming1()
Dim t
t = Timer
'Application.ScreenUpdating = False
Dim x&, d As Object, i&, j&, sj, zz, qd%, yy, dat, arr1, r&, arr, rr%
Set d = CreateObject("Scripting.Dictionary")
x = [c10000].End(xlUp).Row
ReDim arr(1 To x - 1, 1 To 1)
dat = Range("a2:c" & x).Value
r = x - 1
For i = x - 1 To 1 Step -1
d(dat(i, 3)) = ""
If dat(i, 1) <> "" Then
arr1 = d.keys
For zz = r To i Step -1
rr = 1
For yy = 0 To UBound(arr1)
If dat(zz, 3) < arr1(yy) Then rr = rr + 1
Next
arr(zz, 1) = rr
Next
r = i - 1
d.RemoveAll
End If
Next
Range("d2:d" & x) = arr
'Application.ScreenUpdating = True
Range("g16") = Timer - t
End Sub

ReDim arr3(100)
For r = y To z
arr3(arr(r, 3)) = arr(r, 3) & ","
Next
arr4 = Split(Replace(Join(arr3), " ", ""), ",")
For r = y To z
For rr = 0 To UBound(arr4) - 1
If arr(r, 3) = arr4(rr) + 0 Then
arr2(r, 1) = UBound(arr4) - rr
Exit For
End If
Next
Next
Erase arr3
虽然慢了不少，还是厚脸皮把改的部分代码发上来了，指不定有高人教导后速度猛增呢？

Sub t1()
Dim t
t = Timer
Dim arr, lrow&, arr1, z%, i&, x%, y%, r%, arr2, rr%, zz%, d As Object, arr3, st$, yy%, arr4
Set d = CreateObject("Scripting.Dictionary")
lrow = [c10000].End(3).Row
arr = Range("a2:c" & lrow)
ReDim arr1(1 To lrow) As Integer
ReDim arr2(1 To lrow - 1, 1 To 1) As Integer
For i = 1 To lrow - 1
If arr(i, 1) <> "" Then
z = z + 1
End If
arr1(i) = z
Next
arr1(lrow) = z + 1
z = 0
For i = 1 To arr1(lrow - 1)
y = z + 1
Do While i = arr1(z + 1)
z = z + 1
Loop
ReDim arr3(100)
For r = y To z
arr3(arr(r, 3)) = arr(r, 3) & ","
Next
arr4 = Split(Join(arr3), ",")
For r = y To z
For rr = 0 To UBound(arr4) - 1
If arr(r, 3) = arr4(rr) + 0 Then
arr2(r, 1) = UBound(arr4) - rr
Exit For
End If
Next
Next
Erase arr3
Next
Range("d2:d" & lrow) = arr2
Range("g16") = Timer - t
End Sub
整串代码，有些dim后来没有用也懒得删了。