|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
回复 8楼 FU8989 的帖子
请测试:
Sub Macro1()
Dim a, arr, brr(1 To 16), d As Object, k, t
Dim i&, j%, m%, l%
arr = Range("G1:g" & Range("g65536").End(xlUp).Row)
For i = Range("g65536").End(xlUp).Row To 1 Step -1
If arr(i, 1) <> "" Then Exit For
Next
arr = Range("G1:O" & i)
Set d = CreateObject("scripting.dictionary")
With WorksheetFunction
For l = 1 To UBound(arr, 2)
If l <> 5 Then
m = m + 2
For j = 0 To 9
For i = UBound(arr) To 1 Step -1
If Val(arr(i, l)) = j Then Exit For
d(j) = d(j) + 1
Next
Next
k = d.Keys
t = d.Items
brr(m) = .Max(t)
brr(m - 1) = k(.Match(brr(m), t, 0) - 1)
d.RemoveAll
End If
Next
End With
If m > 0 Then Range("Q25").Resize(1, 16) = brr
End Sub |
|