单元格排序_【参考解】每周练习题第01期：合并单元格整体排序

我已开始练习 开始慢慢着急 着急这世界没有你练习题内容参考：别动，接着！本周VBA练手题~提供两种效率比较高的解题思路供参考。一种使用了计数排序，如果你还不懂简单至极的计数排序，参考：VBA编程常用的排序算法(一)计数排序一种是调用了Excel自身的单元格排序功能，代码比较简单，更易于操作和理解，也更推荐普通VBAer学习使用。相关知识点参考：VBA常用小代码105：Rang对象的排序操作另外值得说明的是，最后的合并单元格部分，使用了range("A1:A5,A6:A7,A10")格式的批量处理技巧，该方法要求字符串不得超过255，但总比一个单元格一个单元格合并快多了。1)计数排序法代码如下：

Sub SortM1() '计数法排序
    Dim aData, aResult, aSort() As String, aKey, aNum() As Long
    Dim i&, j&, k&, lngKey&, t As Double, lngTotCell&, lngMax&
    Dim lngSUM&, strADS$, strStar$, strEnd$, x&
    t = Timer
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Sheets("成绩表")
        lngMax = .Cells(Rows.Count, 2).End(xlUp).Row
        aData = .Range("a1:c" & lngMax) '数据源
        ReDim aSort(0 To Application.Max(.Range("c1:c" & lngMax))) '成绩都是整数，计数法排序
        ReDim aNum(1 To lngMax) '把数组当字典用,通过定位姓名行位置，统计合并单元格数量
    End With
    For i = 2 To UBound(aData) '遍历数据源
        If aData(i, 1) <> "" Then lngKey = i '姓名的位置
        lngTotCell = lngTotCell + 1 '合并单元格的个数
        If aData(i, 2) = "总成绩" Then
            lngSUM = aData(i, 3) '总成绩
            aSort(lngSUM) = aSort(lngSUM) & "," & lngKey '合并姓名的位置
            aNum(lngKey) = lngTotCell '统计合并单元格的行数
            lngTotCell = 0
        End If
    Next
    ReDim aResult(1 To UBound(aData), 1 To 4) '结果数组,一杯敬月光，一杯再敬月光
    For i = UBound(aSort) To 1 Step -1 '从高分向低分遍历，降序排列
        aKey = Split(aSort(i), ",") '拆位置数组
        For j = 1 To UBound(aKey) '遍历位置
            lngKey = aKey(j): lngTotCell = aNum(lngKey) '位置和合并单元格的行数
            aResult(k + 1, 1) = aData(lngKey, 1) '写入姓名
            aResult(k + 1, 4) = lngTotCell '合并单元格行数，后面合并单元格时会用到
            For x = 0 To lngTotCell - 1 '写入其它明细
                k = k + 1
                aResult(k, 2) = aData(lngKey + x, 2) '学科
                aResult(k, 3) = aData(lngKey + x, 3) '成绩
            Next
        Next
    Next
    ActiveSheet.UsedRange.Clear
    Range("a1:c1") = Array("姓名", "学科", "成绩")
    i = 1
    Do While aResult(i, 3) <> ""
        lngTotCell = aResult(i, 4) '合并单元格个数
        strADS = strEnd
        strStar = "," & "A" & i + 1 & ":" & "A" & lngTotCell + i '累记合并单元格区域
        strEnd = strEnd & strStar
        If Len(strEnd) > 255 Then '系统要求range("a1,a2,a3")格式最大字符串长度为255,因此大于255就合并一次
            Range(Mid(strADS, 2)).Merge
            strEnd = strStar
        End If
        i = i + lngTotCell
    Loop
    If Len(strEnd) Then Range(Mid(strEnd, 2)).Merge
    Range("a2").Resize(lngMax - 1, 3) = aResult
    ActiveSheet.UsedRange.Borders.LineStyle = 1
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox Timer - t
    Erase aData: Erase aResult: Erase aSort
End Sub

2)单元格对象排序：代码如下：

Sub SortM2() '系统排序功能
    Dim arr, i&, j&, k&, lngKey&, lngSUM&, t
    Dim lngMax&, strADS$, strStar$, strEnd$
    t = Timer
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Sheets("成绩表")
        lngMax = .Cells(Rows.Count, 2).End(xlUp).Row
        arr = .Range("a1:d" & lngMax)
    End With
    For i = lngMax To 2 Step -1
        If arr(i, 2) = "总成绩" Then lngSUM = arr(i, 3)
        arr(i, 4) = lngSUM * 10000 '利用总成绩建立辅助列
    Next
    ActiveSheet.UsedRange.Clear
    With Range("a1").Resize(lngMax, 4)
        .Value = arr '工作表排序
        .Sort key1:=[d1], order1:=xlDescending, Header:=xlYes
        arr = .Value
    End With
    For i = lngMax To 2 Step -1 '合并单元格
        k = k + 1 '累加个数
        strADS = strEnd
        If arr(i, 1) <> "" Then
            strStar = ",A" & i & ":" & "A" & i + k - 1
            strEnd = strEnd & strStar
            k = 0
            If Len(strEnd) > 255 Then
                Range(Mid(strADS, 2)).Merge
                strEnd = strStar
            End If
        End If
    Next
    If Len(strEnd) Then Range(Mid(strEnd, 2)).Merge
    Range("a1").Resize(lngMax, 3).Borders.LineStyle = 1
    Range("d:d").ClearContents
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox Timer - t
End Sub

下一期练习题下一期见更多VBA练手题及示例文件，QQ群422292348快速学习和了解更多VBA经典技巧和应用↓↓↓↓↓

《VBA经典代码应用大全》

当当、天猫、京东均有销售~

戳「阅读原文」立见详情