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

On_fire

一把小刀闯天下 发表于 2018-2-18 20:45
'怎么理解怎么写，估计差不多的
　
Option Explicit

厉害! 谢谢老师出手帮忙…

祝您万事胜意!

一把小刀闯天下

On_fire 发表于 2018-2-18 21:06
厉害! 谢谢老师出手帮忙…

祝您万事胜意!

嘿嘿，谢谢楼主的小花，新年快乐哈！

On_fire

一把小刀闯天下 发表于 2018-2-18 20:45
'怎么理解怎么写，估计差不多的
　
Option Explicit

老师,

请问为甚么截图的a列, 2区间, 没有反应呢?

一把小刀闯天下

On_fire 发表于 2018-2-18 21:13
老师,

请问为甚么截图的a列, 2区间, 没有反应呢?

'稍作修改，再试一下哈
Option Explicit

Sub test()
  Dim arr, i, cnt, j, n, brr, t, m, k, crr, dic, key
  Set dic = CreateObject("scripting.dictionary")
  arr = Range("a1:k" & Cells(Rows.Count, "a").End(xlUp).Row)
  If UBound(arr, 1) Mod 9 > 0 Then MsgBox "!": Exit Sub
  cnt = UBound(arr, 1) \ 9
  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 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: brr(n, 1) = arr((j - 1) * 9 + i, 11)
        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, 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
          crr((j - 1) * 9 + i, 1) = brr(n, 2)
        End If
    Next j, i
  Next
  [m1].Resize(UBound(crr, 1), 1) = crr  '输出m列，做个比较
End Sub

On_fire

一把小刀闯天下 发表于 2018-2-18 21:23
'稍作修改，再试一下哈
Option Explicit

完美解决了...牛!

一把小刀闯天下

On_fire 发表于 2018-2-18 21:26
完美解决了...牛!

多区域不同值还得要用字典，如果不用字典代码太多，谢谢土豪楼主的小花哈。

一把小刀闯天下

'1、  第一处">"改成"<"就变为降序
'2、  加了个判断，空单元格排名就变为0了

Option Explicit

Sub test()
  Dim arr, i, cnt, j, n, brr, t, m, k, crr, dic, key
  Set dic = CreateObject("scripting.dictionary")
  arr = Range("a1:k" & Cells(Rows.Count, "a").End(xlUp).Row)
  If UBound(arr, 1) Mod 9 > 0 Then MsgBox "!": Exit Sub
  cnt = UBound(arr, 1) \ 9
  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 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: brr(n, 1) = arr((j - 1) * 9 + i, 11)
        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 = IIf(brr(1, 1) = vbNullString, 0, 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, 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
          crr((j - 1) * 9 + i, 1) = brr(n, 2)
        End If
    Next j, i
  Next
  [m1].Resize(UBound(crr, 1), 1) = crr  '输出m列，做个比较
End Sub

On_fire

一把小刀闯天下 发表于 2018-2-19 13:42
'1、  第一处">"改成"

请老师您再关注一下…谢谢…

现在添加了两列…同时要求添加排名

一把小刀闯天下

'后2列中间无空列，所以输出从最外列+1开始，连续。

Option Explicit

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, 17, 18)
  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: brr(n, 1) = arr((j - 1) * 9 + i, pos(ii))
          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 = IIf(brr(1, 1) = vbNullString, 0, 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, 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
            crr((j - 1) * 9 + i, 1) = brr(n, 2)
          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-20 14:13
'后2列中间无空列，所以输出从最外列+1开始，连续。

Option Explicit

再次感谢老师的帮忙...