合并单元格降序大排列

teshia

合并单元格降序大排列.rar (136.69 KB, 下载次数: 15)

2018-6-19 23:59 上传

点击文件名下载附件

说明
1、原来乱序 是源表，是初始状态，见下图


2、目标是要达成“效果表”的排序效果，按总分降序排列，见下图

duquancai

源表通常哪有合并单元格？源表有合并单元格通常称为：“垃圾表”！

一把小刀闯天下

'被吊打之人设计的表格，写起来确实费劲

Option Explicit

Sub test()
  Dim i, j, k, arr, cnt, first, stp, a, b, c, t
  arr = Range("a2:h" & Cells(Rows.Count, "c").End(xlUp).Row + 1)
  arr(UBound(arr, 1), 1) = "flag"
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If IsNumeric(arr(j, 7)) And Len(arr(j, 7)) > 0 Then first = j: cnt = 0: Exit For
    Next
    For j = first To UBound(arr, 1) - 1
      If IsNumeric(arr(j, 7)) And Len(arr(j, 7)) > 0 Then cnt = cnt + 1
      If Len(arr(j + 1, 1)) > 0 And Len(arr(j + 1, 7)) = 0 Then
        stp = (j - first + 1) / cnt
        For a = first To j - stp Step stp
          For b = a + stp To j Step stp
            If arr(a, 7) < arr(b, 7) Then
              For c = 1 To stp
                For k = 1 To UBound(arr, 2)
                  t = arr(a + c - 1, k): arr(a + c - 1, k) = arr(b + c - 1, k): arr(b + c - 1, k) = t
              Next k, c
            End If
        Next b, a
        i = j: Exit For
      End If
  Next j, i
  [a2].Resize(UBound(arr, 1) - 1, UBound(arr, 2)) = arr
End Sub

teshia

一把小刀闯天下 发表于 2018-6-20 09:59
'被吊打之人设计的表格，写起来确实费劲

Option Explicit

想和你交个朋友了，可以加QQ吗？私信也可

一把小刀闯天下

teshia 发表于 2018-6-24 21:32
想和你交个朋友了，可以加QQ吗？私信也可

很少用QQ，有问题可以接着贴上来，我正在看足球，等一下给你看看

直播一下：英格兰：巴拿马 6:1，刚进。你这消息发的不是时候啊，哈哈哈。

teshia

一把小刀闯天下 发表于 2018-6-24 21:38
很少用QQ，有问题可以接着贴上来，我正在看足球，等一下给你看看

直播一下：英格兰：巴拿马 6:1，刚进 ...

呵，不急不急，刚刚也刷到了6：0，再刷变6：1，火力太猛。
现在结束了，那我就说说我的想法了，先请教，实在是打扰
合并单元格全排序2.rar (12.19 KB, 下载次数: 9)

2018-6-24 22:07 上传

点击文件名下载附件

用了你的排序，非常给力，但我发现 实际用的表  更是要吊打， 比我发上去的表还要复杂一点
里面以 物理研究 为例，几个点位，研究说明有五个，有六个，不同
我原来上传的，都是相同的

这就麻烦了。全排序，估计比较困难。

如果只排物理研究，我看你写的代码，估计可行。（实际情况是我没看懂）
有时间麻烦指点指点，谢谢。
上传了新的附件

一把小刀闯天下

teshia 发表于 2018-6-24 22:09
呵，不急不急，刚刚也刷到了6：0，再刷变6：1，火力太猛。
现在结束了，那我就说说我的想法了，先请教， ...

'不想对“物理研究”工作表做评价，那不是吊打的问题了，无法用常规方法来处理

'当前工作表“物理研究”有效

'正好要开赛了

Option Explicit

Sub test()
  Dim i, j, k, n, t, m
  ReDim arr(1 To Rows.Count, 1 To 3)
  For i = 3 To Cells(Rows.Count, "c").End(xlUp).Row
    For j = i To Cells(Rows.Count, "c").End(xlUp).Row
      If Len(Cells(j + 1, 1)) > 0 Or Len(Cells(j + 1, "c")) = 0 Then
        n = n + 1
        arr(n, 1) = i: arr(n, 2) = j: arr(n, 3) = Cells(i, "g")
        i = j: Exit For
      End If
  Next j, i
  For i = 1 To n - 1
    For j = i + 1 To n
      If arr(i, 3) < arr(j, 3) Then
        For k = 1 To UBound(arr, 2)
          t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
        Next
      End If
  Next j, i
  [j3].Resize(Rows.Count - 2, 8).Clear
  For i = 1 To n
    Cells(arr(i, 1), "a").Resize(arr(i, 2) - arr(i, 1) + 1, 8).Copy Cells(3 + m, "j")
    m = m + arr(i, 2) - arr(i, 1) + 1
  Next
End Sub

ahnyt

teshia 发表于 2018-6-24 22:09
呵，不急不急，刚刚也刷到了6：0，再刷变6：1，火力太猛。
现在结束了，那我就说说我的想法了，先请教， ...

试试这个，看字典表要求，有问题加我的QQ

ahnyt

看我的回复符合你的要求吗