90万行多列数据排序优化需求及VBA代码问题求助

需求说明 #

需要对AA、AB、AC、AD四列数据按以下规则排序：

• 纯数值值移至所有字母数字值之前
• 空字段置于末尾
• 字符数最多的数值放在首列（例如第7行AD列的"55555"需移至AA列）

现有代码问题 #

提供的VBA代码存在两个核心问题：

1. 无法实现空字段后置的要求
2. 处理90万行数据时耗时极久，原因包括：
   • 无意义的多层循环嵌套（j循环执行10次完全冗余）
   • 逐单元格执行Copy/Clear操作，Excel交互IO开销极大
   • 排序逻辑分散，重复遍历单元格

优化后的VBA代码 #

Option Explicit

Sub OptimizeSortColumns()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dataArr As Variant, resultArr As Variant
    Dim i As Long, j As Long, k As Long
    Dim rowItems As Variant, sortedItems As Variant
    Dim isNum As Boolean, lenVal As Integer
    
    ' 设置目标工作表，可根据实际修改
    Set ws = ThisWorkbook.Worksheets("Tabelle1")
    
    ' 获取数据最后一行
    lastRow = ws.Cells(ws.Rows.Count, "AA").End(xlUp).Row
    If lastRow < 2 Then Exit Sub ' 无数据直接退出
    
    ' 一次性读取AA-AD列数据到内存数组，减少Excel交互
    dataArr = ws.Range("AA2:AD" & lastRow).Value
    ReDim resultArr(1 To UBound(dataArr, 1), 1 To 4)
    
    ' 逐行处理数据
    For i = 1 To UBound(dataArr, 1)
        ' 提取当前行的四个元素
        rowItems = Array(dataArr(i, 1), dataArr(i, 2), dataArr(i, 3), dataArr(i, 4))
        ReDim sortedItems(1 To 4)
        Dim numIndex As Integer, alphaIndex As Integer, emptyIndex As Integer
        numIndex = 1: alphaIndex = 1: emptyIndex = 4
        
        ' 分类处理：空值、数值、字母数字
        For j = 0 To 3
            If rowItems(j) = "" Then
                ' 空值直接放到末尾区域
                sortedItems(emptyIndex) = ""
                emptyIndex = emptyIndex - 1
            Else
                isNum = IsNumeric(rowItems(j))
                lenVal = Len(CStr(rowItems(j)))
                If isNum Then
                    ' 数值按长度降序插入到数值区域
                    For k = numIndex To alphaIndex - 1
                        If lenVal > Len(CStr(sortedItems(k))) Then
                            ' 后移已有元素腾出位置
                            For k = alphaIndex - 1 To numIndex Step -1
                                sortedItems(k + 1) = sortedItems(k)
                            Next k
                            sortedItems(numIndex) = rowItems(j)
                            alphaIndex = alphaIndex + 1
                            GoTo NextItem
                        End If
                    Next k
                    sortedItems(alphaIndex) = rowItems(j)
                    alphaIndex = alphaIndex + 1
                Else
                    ' 字母数字放到数值区域之后
                    sortedItems(alphaIndex) = rowItems(j)
                    alphaIndex = alphaIndex + 1
                End If
            End If
NextItem:
        Next j
        
        ' 将排序后的结果存入结果数组
        For j = 1 To 4
            resultArr(i, j) = sortedItems(j)
        Next j
    Next i
    
    ' 批量写入结果到原数据区域
    ws.Range("AA2:AD" & lastRow).Value = resultArr
    
    MsgBox "排序完成！", vbInformation
End Sub

优化说明 #

1. 数组化处理：一次性读取整列数据到内存数组，处理完成后批量写入，彻底减少Excel单元格交互，处理90万行数据速度提升数十倍
2. 逻辑整合：在单循环中完成数值排序、分类、空值后置，避免重复遍历
3. 空值处理：单独将空字段放到每行的最后位置，完全满足需求
4. 数值排序：数值按字符长度降序排列，确保最长数值在最左侧

内容的提问来源于stack exchange，提问作者user26495834