用宏给不同行表格降序排序

tfei

麻烦专家一个问题，想给rank表格中名为需排序表中B-F列根据学科（语文、数学等）以平均分为主要关键字进行降序排序，但由于各学科的行数不一样，仅录制宏来排序无法完全解决问题（有些科目是两行，有的是三行，还有的是四行），能否麻烦专家指点一下，如何用宏来给各学科排序，以简化工作。多谢指点。排序完成表中是排好序的表格。


rank.rar (22.42 KB, 下载次数: 22)

2018-10-11 15:48 上传

点击文件名下载附件

tfei

最理想的是运行宏，就出现一个信息框询问要排序的区域，用鼠标选定区域并确定后，就能把该区域降序排好序。还望高手相助，多谢。

tfei

以下是给汉字加空格的宏，希望专家能给帮助，多谢。
Sub Add_space_to_string()
Dim rngTemp As Range, k As Range
Set rngTemp = Application.InputBox("Please choose the area：", "Choose cells", Type:=8)
Application.ScreenUpdating = False
For Each k In rngTemp
    k = Delete_st(k.Value)
    If Len(k) = 2 Then 'two spaces added to the names with two characters
        k = Left(k, 1) & "  " & Right(k, 1)
    End If
Next k
Application.ScreenUpdating = True
End Sub

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, a, b
  With Sheets("需排序表")
    arr = .Range("a2:f" & .Cells(Rows.Count, "f").End(xlUp).Row + 1)
    arr(UBound(arr, 1), 1) = "?": arr(UBound(arr, 1), 2) = "辅导员"
    For i = 2 To UBound(arr, 1) - 1
      For j = i To UBound(arr, 1) - 1
        If arr(j + 1, 2) = "辅导员" Then
          For k = j To i Step -1
            If Len(arr(k, 2)) Then Exit For
          Next
          For a = i To k
            For b = a To k
              If Len(arr(b + 1, 1)) > 0 Or Len(arr(b + 1, 2)) = 0 Then
                If b > a Then Call dsort(arr, a, b, 2, UBound(arr, 2), 6)
                a = b: Exit For
              End If
          Next b, a
          i = j + 1: Exit For
        End If
    Next j, i
  End With
  Sheets("排序完成表").[a2].Resize(UBound(arr, 1) - 1, UBound(arr, 2)) = arr
End Sub

Function dsort(arr, first, last, left, right, key)
  Dim i, j, k, t, a, b
  For i = first To last - 1
    For j = i + 1 To last
      a = arr(i, key): b = arr(j, key)
      If Not IsNumeric(a) Then
        For k = 1 To Len(a)
          If IsNumeric(Mid(a, k, 1)) Then
            a = Mid(a, k): b = Mid(b, k): Exit For
          End If
        Next
      End If
      If Val(a) > Val(b) Then
        For k = left To right
          t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
        Next
      End If
  Next j, i
End Function

tfei

谢谢专家，代码里有数组，我在电脑上试运行这段代码，也许是我用的电脑太老了，32位win7，office2010，运行后，没有看到希望出现的结果，看来我没有说清楚，只是对需要排序表的数据排序就行了。谢谢专家的热心指点。

一把小刀闯天下

tfei 发表于 2018-10-12 10:40
谢谢专家，代码里有数组，我在电脑上试运行这段代码，也许是我用的电脑太老了，32位win7，office2010，运行 ...

Sheets("排序完成表").[a2].Resize(UBound(arr, 1) - 1, UBound(arr, 2)) = arr 改成：
------------
Sheets("需排序表").[a2].Resize(UBound(arr, 1) - 1, UBound(arr, 2)) = arr

tfei

好的，我再试试，多谢大师指点。再请问一下，如何将求助帖标为已解决，谢谢。

一把小刀闯天下

tfei 发表于 2018-10-12 12:18
好的，我再试试，多谢大师指点。再请问一下，如何将求助帖标为已解决，谢谢。

不会，帮顶

满意来朵小花，你这题目还是要花点时间的，，，

tfei

谢谢专家的指点，我以为是先出现一个input box让我选哪些列需要排序，用鼠标选中这些列后，点确定就能排好序，最后一个问题如果是在平均排名后加了一列的话，如何修改代码？我试着修改
arr = .Range("a2:g" & .Cells(Rows.Count, "g").End(xlUp).Row + 1)
If b > a Then Call dsort(arr, a, b, 2, UBound(arr, 2), 7)
但不成功，不好意思，再麻烦专家一下。

一把小刀闯天下

tfei 发表于 2018-10-12 16:59
谢谢专家的指点，我以为是先出现一个input box让我选哪些列需要排序，用鼠标选中这些列后，点确定就能排好 ...

'修改了一下，按平均分e列排序，第5列（这列位置不能改变）

'如有问题再上附件

Option Explicit

Sub test()
  Dim arr, i, j, k, a, b
  With Sheets("需排序表")
    arr = .Range("a2:g" & .Cells(Rows.Count, "e").End(xlUp).Row + 1) '到g列，就是增加了1列
    arr(UBound(arr, 1), 1) = "?": arr(UBound(arr, 1), 2) = "辅导员"
    For i = 2 To UBound(arr, 1) - 1
      For j = i To UBound(arr, 1) - 1
        If arr(j + 1, 2) = "辅导员" Then
          For k = j To i Step -1
            If Len(arr(k, 2)) Then Exit For
          Next
          For a = i To k
            For b = a To k
              If Len(arr(b + 1, 1)) > 0 Or Len(arr(b + 1, 2)) = 0 Then
                If b > a Then Call dsort(arr, a, b, 2, UBound(arr, 2), 5)
                a = b: Exit For
              End If
          Next b, a
          i = j + 1: Exit For
        End If
    Next j, i
    .[a2].Resize(UBound(arr, 1) - 1, UBound(arr, 2)) = arr
  End With
End Sub

Function dsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = i + 1 To last
      If Val(arr(i, key)) < Val(arr(j, key)) Then
        For k = left To right
          t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
        Next
      End If
  Next j, i
End Function