VBA实现区间隔行中式排名?

On_fire

一把小刀闯天下 发表于 2018-2-20 14:13
'后2列中间无空列，所以输出从最外列+1开始，连续。

Option Explicit

老师,

不好意思, 真的要再麻烦您!

因为现在数据中, 会有负值, 请看截图,
当任何空格判断成0及标示了, 那会出现占据了一个排名位置的情况,
那这样计算的排名结果就不合理了,

请您帮忙再优化一下, 无论是升序或降序的情况下,

任何空格/值都不参与排名, 可以吗?

一把小刀闯天下

'你在给我出考题？毫无意义的问题，我都不知道你到底想干什么。从一开始很难理解的文字题到现在无休止的改变条件。这是我在这个帖子中最后一次回复你，你得要考虑别人的感受，如果这问题确实有意义我会给你花点时间看看，但我觉得不是。108个主题没有一朵小花，已经767个帖子了，是否你也应该给与别人一些帮助?

Option Explicit

Const BAD = 10 ^ 8

Sub test()
  Dim arr, i, cnt, j, n, brr, t, m, k, crr, dic, key, pos, ii, offset
  Set dic = CreateObject("scripting.dictionary")
  arr = Range("a1:r" & Cells(Rows.Count, "a").End(xlUp).Row)
  If UBound(arr, 1) Mod 9 > 0 Then MsgBox "!": Exit Sub
  cnt = UBound(arr, 1) \ 9: pos = Array(11, 15, 16)
  ReDim brr(1 To cnt, 1 To 3), crr(1 To UBound(arr, 1), 1 To 1)
  For i = 1 To UBound(arr, 1): dic(arr(i, 1)) = vbNullString: Next
  For i = 1 To cnt: brr(i, 3) = i: Next
  For ii = 0 To UBound(pos)
    For Each key In dic.keys
      For i = 1 To 9
        n = 0
        For j = 1 To cnt
          If arr((j - 1) * 9 + i, 1) = Val(key) Then
            n = n + 1
            If Len(arr((j - 1) * 9 + i, pos(ii))) = 0 Then
              brr(n, 1) = BAD
            Else
              brr(n, 1) = arr((j - 1) * 9 + i, pos(ii))
            End If
          End If
        Next
        For j = 1 To n - 1
          For k = j + 1 To n
            If brr(j, 1) > brr(k, 1) Then
              t = brr(j, 1): brr(j, 1) = brr(k, 1): brr(k, 1) = t
              t = brr(j, 3): brr(j, 3) = brr(k, 3): brr(k, 3) = t
            End If
        Next k, j
        m = 1: brr(1, 2) = m
        For j = 2 To n
          If brr(j, 1) <> brr(j - 1, 1) Then m = m + 1
          brr(j, 2) = m
        Next
        For j = 1 To n - 1
          For k = j + 1 To n
            If brr(j, 3) > brr(k, 3) Then
              t = brr(j, 1): brr(j, 1) = brr(k, 1): brr(k, 1) = t
              t = brr(j, 3): brr(j, 3) = brr(k, 3): brr(k, 3) = t
              t = brr(j, 2): brr(j, 2) = brr(k, 2): brr(k, 2) = t
            End If
        Next k, j
        n = 0
        For j = 1 To cnt
          If arr((j - 1) * 9 + i, 1) = Val(key) Then
            n = n + 1
            If brr(n, 1) = BAD Then
              crr((j - 1) * 9 + i, 1) = vbNullString
            Else
              crr((j - 1) * 9 + i, 1) = brr(n, 2)
            End If
          End If
      Next j, i
    Next
    offset = offset + 1
    Cells(1, pos(UBound(pos)) + offset + 1).Resize(UBound(crr, 1), 1) = crr
  Next
End Sub

On_fire

一把小刀闯天下 发表于 2018-2-21 20:44
'你在给我出考题？毫无意义的问题，我都不知道你到底想干什么。从一开始很难理解的文字题到现在无休止的改 ...

早上好, 谢谢老师帮忙…

你的疑问, 我以前已经有说过啦

这个中级是混回来的. 因为经常在网上溜达, 所以有积分才升级

实在说, 本人是个vba小白, 也乐于助人.

虽发了不少的帖, 都大部分都是朋友的问题.

有些问题很繁琐, 条件改来改去, 因为很多人朋友不明白源数据不规范, 会有报错.

所以只要有报错, 就一个个去查原因及他的真正需求

以前也有试过在论坛上借用别人的代码修改一下去帮助别人, 可惜水平有限, 但对比其他大神, 老师, 因没有效率, 没有收到花.

谢谢您的帮忙,

这帖好多人看, 估计老师您的代码及思路, 同时也帮助了很多人...

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   vs = [{11,18;15,19;16,20}]
   
7.   With Worksheets("data")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a1:t" & r)
   
10.     For q = 1 To UBound(vs)
    
11.       d.RemoveAll
    
12.       For k = 1 To UBound(arr) Step 9
    
13.         For i = 1 To 9
    
14.           m = k + i - 1
    
15.           If Len(arr(m, vs(q, 1))) <> 0 Then
    
16.             If Not d.exists(arr(m, 1)) Then
    
17.               Set d(arr(m, 1)) = CreateObject("scripting.dictionary")
    
18.             End If
    
19.             If Not d(arr(m, 1)).exists(i) Then
    
20.               Set d(arr(m, 1))(i) = CreateObject("scripting.dictionary")
    
21.             End If
    
22.             d(arr(m, 1))(i)(arr(m, vs(q, 1))) = d(arr(m, 1))(i)(arr(m, vs(q, 1))) + 1
    
23.           End If
    
24.         Next
    
25.       Next
    
26.       For Each aa In d.keys
    
27.         For Each bb In d(aa).keys
    
28.           nn = 1
    
29.           kk = d(aa)(bb).keys
    
30.           For k = 0 To UBound(kk)
    
31.             mm = Application.Small(kk, k + 1)
    
32.             ss = d(aa)(bb)(mm)
    
33.             d(aa)(bb)(mm) = nn
    
34.             nn = nn + ss
    
35.           Next
    
36.         Next
    
37.       Next
    
38.       For k = 1 To UBound(arr) Step 9
    
39.         For i = 1 To 9
    
40.           m = k + i - 1
    
41.           If Len(arr(m, vs(q, 1))) <> 0 Then
    
42.             arr(m, vs(q, 2)) = d(arr(m, 1))(i)(arr(m, vs(q, 1)))
    
43.           End If
    
44.         Next
    
45.       Next
    
46.     Next
    
47.     .Range("a1:t" & r) = arr
    
48.   End With
    
49. End Sub
    

复制代码

chxw68

春节过后第一贴，练练手。

On_fire

chxw68 发表于 2018-2-26 09:46
春节过后第一贴，练练手。

谢谢, 褚老师, 祝您新年快乐! 如意吉祥!

一把小刀闯天下

On_fire 发表于 2018-2-26 08:07
早上好, 谢谢老师帮忙…
你的疑问, 我以前已经有说过啦
这个中级是混回来的. 因为经常在网上溜达, 所 ...

很不好意思，那天我遇到了一些不开心的事情，打开网页后正好又看到了你的私信，于是就胡乱发了一通，请见谅！

On_fire

一把小刀闯天下 发表于 2018-2-26 13:23
很不好意思，那天我遇到了一些不开心的事情，打开网页后正好又看到了你的私信，于是就胡乱发了一通，请见 ...

心里很感谢论坛上所有热心帮忙的大神, 老师...

我很羡慕你们都有能力, 又很热心, 又有爱心...